Attribute VB_Name = "GlobalSubroutines"
Option Explicit
'*********General Section************
'Declarations for Windows API calls
Public Declare Function GetFocus Lib "user32" () As Long
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Public Declare Function GetLocaleInfoA Lib "kernel32" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String, ByVal cchData As Long) As Long
Public Declare Function GetUserDefaultLCID Lib "kernel32" () As Long
Public Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Public Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Integer) As Integer
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function GetActiveWindow Lib "user32" () As Long
Public Const LOCALE_SDECIMAL = &HE ' decimal separator
Public Const LOCALE_STHOUSAND = &HF ' thousand separator
Public Const LOCALE_IDIGITS = &H11 ' number of fractional digits
Public Const WM_USER = &H400
Public Const FGLB_NO_DATA = 0
Public Const FGLB_REAL_TIME_DATA = 1
Public Const FGLB_HISTORICAL_DATA = 2
Public Const FGLB_TAGGROUP_DATA = 3
Public Const FGLB_UNKNOWN_DATA = 15
Option Compare Text 'jlk04099
Private Declare Function IsCharAlpha Lib "user32" Alias "IsCharAlphaA" (ByVal cChar As Byte) As Long
'Flag for Disabling Error Handling
Public DisableErrorHandling As Boolean
'Flag for DataEntry Form
Public blnDataEntryFrmFlag As Boolean
'Public Variables for creating instances of the runtime DataEntry Experts
Public Numeric As frmNumericEntry
Public Pushbutton As frmPushbuttonEntry
Public Ramp As frmRampEntry
Public Slider As frmSliderEntry
Public PrintReportXI As frmPrintReportXI
'Public variable for creating and instance of the Dynamo ColorBy form
Public frmDynamoColor As frmDynamoColorBy
'Public collection for the AcknowledgeAllAlarms, GetAllAlarmConnections and GetAllConnections subroutine
Public AllConnectionsCollection As New Collection
'Public Declares for Crystal Report routines
Public Declare Function PEOpenEngine Lib "crpe32.dll" () As Integer
Public Declare Sub PECloseEngine Lib "crpe32.dll" ()
Public CrystalApplication As Object
'lad 040902 Tracker #2195 - public flag for AcknowledgeAllAlarms, AckAllAlarmSummary
Public bAlarmSummaryFlag As Boolean
'Public structure for packaging picture information
Type PictureInfo
lfTopPct As Double
lfLeftPct As Double
lfHeightPct As Double
lfWidthPct As Double
lBkColor As Long
szName As String
bPixels As Boolean
bTitlebar As Boolean
bSystemMenu As Boolean
bResizable As Boolean
bAlwaysOnTop As Boolean
bRuntimeVisible As Boolean
End Type
'PBH 12/16/2004 enumerated type for the tag status open pic and replace pic functionality
Enum TS_PIC_TYPE
NONE = -1
TAGSTATUS = 0
QUICKTREND = 1
TAGCONTROLPANEL = 2
End Enum
Const ERR_NUM_PICNOTFOUND = 1000 + vbObjectError
Const ERR_NUM_PICNOTEXIST = 1010 + vbObjectError
Const ERR_NUM_UNDEFINEDDATASOURCE = 1020 + vbObjectError
Const ERR_NUM_NOOBJECTSELECTEDFORROUTINE = 1030 + vbObjectError
Const ERR_NUM_DATASOURCEINVALIDSYNTAX = 1040 + vbObjectError
Const ERR_NUM_DATASOURCEDATATYPEMISMATCH = 1050 + vbObjectError
Const ERR_NUM_NOCONNECTIONTODATASOURCE = 1060 + vbObjectError
Const ERR_NUM_PICNOTOPEN = 1070 + vbObjectError
Const ERR_NUM_CRYSTALREPORTSNOTINSTALLED = 1080 + vbObjectError
Const ERR_NUM_CRYSTALREPORTSVERSIONERROR = 1090 + vbObjectError
Const ERR_NUM_FIELDVALUESUNKNOWN = 1100 + vbObjectError
Const ERR_NUM_PICALREADYOPEN = 1110 + vbObjectError 'Arjun Port T6296 CMK 1-459557143 040908
Const KMEERR_KMENOTSUPRTD = 3001
Public Declare Function HtmlHelp Lib "hhctrl.ocx" _
Alias "HtmlHelpA" _
(ByVal hwndCaller As Long, _
ByVal pszFile As String, _
ByVal uCommand As Long, _
ByVal dwData As Long) _
As Long
Public Const HH_HELP_CONTEXT = &HF
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpszClassName As String, ByVal lpszWindow As String) As Long
Private Declare Function GetEnvironmentVariable Lib "kernel32" _
Alias "GetEnvironmentVariableA" (ByVal lpName As String, _
ByVal lpBuffer As String, ByVal nSize As Long) As Long
Public Sub AtStartUp()
' bjm102898 This empty macro is needed to allow the WorkSpace to force VBA
' initialization.
Dim r As Integer
r = 1
End Sub
'**********************Get Decimal Separator**************************
'This function returns the decimal separator set in the machine's Regional Settings.
Public Function GetDecimalSeparator(Optional intErrorMode As Integer = 0)
Dim intCountChar As Integer
Dim lngHolder As Long
Dim strDecChar As String
On Error GoTo ErrorHandler
strDecChar = Space$(255)
'Get the decimal character (strDecChar) and the count of characters for the thousand separator (lngHolder).
lngHolder = GetLocaleInfoA(GetUserDefaultLCID(), LOCALE_SDECIMAL, strDecChar, Len(strDecChar) + 1)
GetDecimalSeparator = Left$(strDecChar, lngHolder - 1)
Exit Function
ErrorHandler:
HandleError (intErrorMode)
End Function
'**********************Get Form Dynamo Color By*******************************
'This subroutine assigns the Dynamo ColorBy form a global variable so that it can be accessed
'from Factory Globals by other projects.
Public Sub GetFormDynamoColor(DynColor As Object)
Set DynColor = New frmDynamoColorBy
End Sub
'*********************Get Form Numeric****************************************
'Subroutine that assigns the DataEntry's Numeric Entry form a global variable
'So the form can be accessed from Factory Globals in Runtime by other projects.
Public Sub GetFormNumeric()
Set Numeric = New frmNumericEntry
End Sub
'*********************Get Form Ramp*********************************************
'Subroutine that assigns the DataEntry's Ramp Entry form a global variable
'So the form can be accessed from Factory Globals in Runtime by other projects.
Public Sub GetFormRamp()
Set Ramp = New frmRampEntry
End Sub
'*********************Get Form Pushbutton*********************************************
'Subroutine that assigns the DataEntry's PushButton Entry form a global variable
'So the form can be accessed from Factory Globals in Runtime by other projects.
Public Sub GetFormPushbutton()
Set Pushbutton = New frmPushbuttonEntry
End Sub
'*********************Get Form Slider*********************************************
'Subroutine that assigns the DataEntry's Slider Entry form a global variable
'So the form can be accessed from Factory Globals in Runtime by other projects.
Public Sub GetFormSlider()
Set Slider = New frmSliderEntry
End Sub
'**********************Find Data Source*******************************************
'This function finds the Data Source for the object entered in the first parameter. If the user enters
'a property in the second parameter, this function finds the data source connected to that property.
'If the user does not enter a property, it finds the data source for the first property with a connection.
Public Function FindDataSource(Object As Object, Optional strProperty As String) As String
Dim strProp As String
Dim lConnectedCount As Long
Dim iNumProperties As Integer
Dim strSource As String
Dim strFullyQualifiedSource As String
Dim vtsourceobjects As Variant
Dim bHasConnection As Boolean
Dim lIndex As Long
Dim lStatus As Long
Dim i As Integer
Dim strUltimateSource As String
'If the user did not enter a property for finding the connected data source, check how many
'of the object's properties are connected to data sources.
If strProperty = "" Then
Object.ConnectedPropertyCount lConnectedCount
iNumProperties = CInt(lConnectedCount)
'If no properties are connected to a data source, return an empty string and exit the function.
If iNumProperties = 0 Then
FindDataSource = ""
Exit Function
End If
'For each connected property, get the connection information
For i = 1 To iNumProperties
Object.GetConnectionInformation i, strProp, strSource, strFullyQualifiedSource, vtsourceobjects
If vtsourceobjects(0).ClassName = "OPCDataItem" Then
FindDataSource = vtsourceobjects(0).FullyQualifiedName
Exit Function
Else
Call lUltimateDataSource(vtsourceobjects(0), strProperty, strUltimateSource)
FindDataSource = strUltimateSource
Exit Function
End If
Next
'If user passes in the name of the property that may be connected to a data source
Else
Object.IsConnected strProperty, bHasConnection, lIndex, lStatus
If bHasConnection Then
Object.GetConnectionInformation lIndex, strProperty, strSource, strFullyQualifiedSource, vtsourceobjects
If vtsourceobjects(0).ClassName = "OPCDataItem" Then
FindDataSource = vtsourceobjects(0).FullyQualifiedName
Else
Call lUltimateDataSource(vtsourceobjects(0), strProperty, strUltimateSource)
FindDataSource = strUltimateSource
End If
End If
End If
End Function
'***********************Find Ultimate Data Source*****************************
Private Sub lUltimateDataSource(SourceObject As Variant, strProperty As String, strUltimateSource As String)
Dim iNumProperties As Integer
Dim strSource As String
Dim strFullyQualifiedSource As String
Dim vtsourceobjects As Variant
Dim lIndex As Long
Dim lStatus As Long
Dim i As Integer
Dim lConnectedCount As Long
Dim NewSource As Object
'For the object passed into the subroutine, get a list of all of its connections
SourceObject.ConnectedPropertyCount lConnectedCount
iNumProperties = CInt(lConnectedCount)
'If there are connections to the object, get the connection information
If iNumProperties <> 0 Then
For i = 1 To iNumProperties
SourceObject.GetConnectionInformation i, strProperty, strSource, strFullyQualifiedSource, vtsourceobjects
'If the object is a FixGlobalSysInfo object, it does not support the ClassName
'property so skip it.
If TypeName(vtsourceobjects(0)) <> "FixGlobalSysInfo" Then
'If the object is connected to an OPCDataItem object, add the OPCDataItem object
'to the collection.
If UCase(vtsourceobjects(0).ClassName) = "COPCDATAITEM" Then
strUltimateSource = vtsourceobjects(0).FullyQualifiedName
Exit Sub
Else
'jlk moved from below
vtsourceobjects(0).ConnectedPropertyCount lConnectedCount
If lConnectedCount > 0 Then
Call lUltimateDataSource(vtsourceobjects(0), strProperty, strUltimateSource)
If strUltimateSource <> "" Then
Exit Sub
End If
End If
End If
End If
Next
End If
'jlk moved above
' vtSourceObjects(0).ConnectedPropertyCount lConnectedCount
'If lConnectedCount > 0 Then
' vtSourceObjects(0).GetConnectionInformation 1, strProperty, strSource, strFullyQualifiedSource, vtSourceObjects
' Call lUltimateDataSource(vtSourceObjects(0), strProperty, strUltimateSource)
'End If
End Sub
'*****************************Open Picture***************************************
' MOD LOG
' Version Date Name Bug# Description
' -------- --------- ---- ----------- -------------------------------------------------
' 4.0 10/25/2005 PBH T2121 Handle case when PictureObject is Null
' 4.5 03/12/2007 jtt Add new Boolean parameter bNewInstance
' 4.5 04/20/2007 PBH Jeff's changes didn't allow for Tag Status Pictures to participate
' in multiple instance opening. Made sufficient changes to allow for this now.
'
Public Sub OpenPicture(Optional Picture As String, Optional PictureAlias As String, Optional TopPosition As Variant, Optional LeftPosition As Variant, Optional intErrorMode As Integer = 0, Optional CallingPictureObject As Object = Nothing, Optional TSPicType As TS_PIC_TYPE = NONE, Optional TagList As Variant = Nothing, Optional bNewInstance As Boolean = False)
'Public Sub OpenPicture(Optional Picture As String, Optional PictureAlias As String, Optional TopPosition As Variant, Optional LeftPosition As Variant, Optional intErrorMode As Integer = 0)
Dim AppObj As Object
Dim PictureObject As Object
Dim blnWorkspaceNotRunning As Boolean
Dim bOpenTagStatusPic As Boolean
Dim intOpenMode As Integer
bOpenTagStatusPic = False
If intErrorMode <> 1 Then
On Error GoTo ErrorHandler
End If
'jtt03122007
If bNewInstance = False Then
intOpenMode = 2 'Open hidden
Else
intOpenMode = 6 'Open hidden new instance
End If
' Is this script running in the workspace or background
If TypeName(Application) = "CFixApp" Then
' running in the workspace
Set AppObj = Application
blnWorkspaceNotRunning = False
Else
' running in the background
' see if we can get the workspace object
Set AppObj = App
If AppObj Is Nothing Then
Exit Sub
Else
blnWorkspaceNotRunning = False
End If
End If
'PBH 12/16/2004 only when no picture string has been provided to this function will we even bother to check
' for tag status information.
If Picture = "" Then
If Not (CallingPictureObject Is Nothing) Then
If TSPicType <> NONE Then
If TypeName(CallingPictureObject) = "CFixPicture" Then
bOpenTagStatusPic = True
End If
End If
End If
If bOpenTagStatusPic = False Then
Set PictureObject = AppObj.Documents.Open("", intOpenMode)
'If the user doesn't select Cancel from the Open dialog box, open the picture they select
If TypeName(PictureObject) <> "Nothing" Then
'Set up the top and left position
If Not IsMissing(TopPosition) Then
If TopPosition <> "" Then 'T3730 rp050802 - jes script authoring wizard passes ""
If TopPosition = Empty Then
PictureObject.ActiveWindow.Top = 0
Else
PictureObject.ActiveWindow.Top = CDbl(TopPosition)
End If
End If
End If
If Not IsMissing(LeftPosition) Then
If LeftPosition <> "" Then 'T3730 rp050802 -jes script authoring wizard passes ""
If LeftPosition = Empty Then
PictureObject.ActiveWindow.Left = 0
Else
PictureObject.ActiveWindow.Left = CDbl(LeftPosition)
End If
End If
End If
'Make the page visible in the run environment and make the new picture active.
'jtt040699 no longer need to set runtimevisible, code is fixed in the active property
'pictureobject.page.runtimevisible = True
PictureObject.ActiveWindow.active = True
End If
'If the user entered a picture alias, set the alias for the picture
If PictureAlias <> "" Then
PictureObject.ActiveWindow.WindowName = PictureAlias
End If
Exit Sub
End If
End If
If bOpenTagStatusPic = False Then
'Check for "\" in string to see if a full path name is supplied.
If InStr(1, Picture, "\", vbTextCompare) <> 0 Then
'If it is supplied, check to see if file's extension is supplied.
If InStr(1, Picture, ".", vbTextCompare) = 0 Then
'add on ".grf" to the file name
Picture = Picture & ".grf"
'If the file extension is supplied, make sure it is ".grf". If it is not, go to the NoSuchPicture message.
ElseIf InStr(1, Picture, "grf", vbTextCompare) = 0 Then
GoTo NoSuchPicture
End If
'Check to see if this file actually exists.
If Dir(Picture) = "" Then
GoTo NoSuchPicture
Else
'If the file does exist, open it.
Set PictureObject = AppObj.Documents.Open(Picture, intOpenMode)
'Takes care of problem with Active Window
If blnWorkspaceNotRunning = False Then
If Not IsMissing(TopPosition) Then
If TopPosition <> "" Then 'T3730 rp050802 jes script authoring wizard passes ""
If TopPosition = Empty Then
PictureObject.ActiveWindow.Top = 0
Else
PictureObject.ActiveWindow.Top = CDbl(TopPosition)
End If
End If
End If
If Not IsMissing(LeftPosition) Then
If LeftPosition <> "" Then 'T3730 rp050802 jes script authoring wizard passes ""
If LeftPosition = Empty Then
PictureObject.ActiveWindow.Left = 0
Else
PictureObject.ActiveWindow.Left = CDbl(LeftPosition)
End If
End If
End If
PictureObject.ActiveWindow.WindowName = PictureAlias
End If
If (TypeName(PictureObject) = "Nothing") Then
GoTo NoSuchPicture
Exit Sub
End If
'jtt040699 no longer need to set runtimevisible, code is fixed in the active property
'pictureobject.page.runtimevisible = True
PictureObject.ActiveWindow.active = True
Exit Sub
End If
'If there is no "\" in the Picture string, the user did not specify the full path. Check
'to see if the user supplied an extension.
Else
If InStr(1, Picture, ".", vbTextCompare) = 0 Then
'add on ".grf" to the file name
Picture = Picture & ".grf"
ElseIf InStr(1, Picture, "grf", vbTextCompare) = 0 Then
GoTo NoSuchPicture
Exit Sub
End If
'Add the Fix Pic path to the file name
Picture = System.picturepath & "\" & Picture
If Dir(Picture) = "" Then
GoTo NoSuchPicture
Else
Set PictureObject = AppObj.Documents.Open(Picture, intOpenMode)
If blnWorkspaceNotRunning = False Then
If Not IsMissing(TopPosition) Then
If TopPosition <> "" Then 'T3730 rp050802jes script authoring wizard passes ""
If TopPosition = Empty Then
PictureObject.ActiveWindow.Top = 0
Else
PictureObject.ActiveWindow.Top = CDbl(TopPosition)
End If
End If
End If
If Not IsMissing(LeftPosition) Then
If LeftPosition <> "" Then 'T3730 rp050802 jes script authoring wizard passes ""
If LeftPosition = Empty Then
PictureObject.ActiveWindow.Left = 0
Else
PictureObject.ActiveWindow.Left = CDbl(LeftPosition)
End If
End If
End If
PictureObject.ActiveWindow.WindowName = PictureAlias
'jtt040699 no longer need to set runtimevisible, code is fixed in the active property
'pictureobject.page.runtimevisible = True
PictureObject.ActiveWindow.active = True
End If
If (TypeName(PictureObject) = "Nothing") Then
ErrorOption intErrorMode, ERR_NUM_PICNOTEXIST, NLSStrMgr.GetNLSStr(1167, Picture)
End If
End If ' END If Dir(Picture) = "" Then
End If ' END If InStr(1, Picture, "\", vbTextCompare) <> 0 Then
Else
' open a tag status feature picture here
Dim TypeNameString As String
TypeNameString = TypeName(TagList)
If (True = bNewInstance) Then
If (TypeNameString = "String()") Then ' Pass a taglist to open_pic
Set PictureObject = CallingPictureObject.Open_TS_Pic_Type_Ex(TSPicType, TagList, 1)
Else
If TSPicType = TAGSTATUS Then
Set PictureObject = CallingPictureObject.Open_TS_Pic_Ex(1)
ElseIf TSPicType = QUICKTREND Then
Set PictureObject = CallingPictureObject.Open_QT_Pic(1)
ElseIf TSPicType = TAGCONTROLPANEL Then
Set PictureObject = CallingPictureObject.Open_TCP_Pic(1)
Else
Exit Sub ' Coming here indicates our checks up above were not sufficient since we should not be trying a tag status feature unless the TSPicType was set properly.
End If
End If
Else
If (TypeNameString = "String()") Then ' Pass a taglist to open_pic
Set PictureObject = CallingPictureObject.Open_TS_Pic_Type(TSPicType, TagList)
Else
If TSPicType = TAGSTATUS Then
Set PictureObject = CallingPictureObject.Open_TS_Pic
ElseIf TSPicType = QUICKTREND Then
Set PictureObject = CallingPictureObject.Open_QT_Pic
ElseIf TSPicType = TAGCONTROLPANEL Then
Set PictureObject = CallingPictureObject.Open_TCP_Pic
Else
Exit Sub ' Coming here indicates our checks up above were not sufficient since we should not be trying a tag status feature unless the TSPicType was set properly.
End If
End If
End If
If TypeName(PictureObject) <> "Nothing" Then ' Don't use the PictureObject variable unless it's been initialized.
If blnWorkspaceNotRunning = False Then
If Not IsMissing(TopPosition) Then
If TopPosition <> "" Then 'T3730 rp050802jes script authoring wizard passes ""
If TopPosition = Empty Then
PictureObject.ActiveWindow.Top = 0
Else
PictureObject.ActiveWindow.Top = CDbl(TopPosition)
End If
End If
End If
If Not IsMissing(LeftPosition) Then
If LeftPosition <> "" Then 'T3730 rp050802 jes script authoring wizard passes ""
If LeftPosition = Empty Then
PictureObject.ActiveWindow.Left = 0
Else
PictureObject.ActiveWindow.Left = CDbl(LeftPosition)
End If
End If
End If
PictureObject.ActiveWindow.WindowName = PictureAlias
'jtt040699 no longer need to set runtimevisible, code is fixed in the active property
'pictureobject.page.runtimevisible = True
PictureObject.ActiveWindow.active = True
End If
End If
End If ' END If bOpenTagStatusPic = False Then
Exit Sub
NoSuchPicture:
ErrorOption intErrorMode, ERR_NUM_PICNOTFOUND, NLSStrMgr.GetNLSStr(1024, Picture)
Exit Sub
ErrorHandler:
'Check for Security Failure
If Err.number = -2147196405 Then
Exit Sub
End If
If Err.number = -2147211312 Then
Exit Sub
End If
'Check for could not be found error, Open automation already handled this error
If Err.number = -2147287038 Then
Exit Sub
End If
HandleError (intErrorMode)
End Sub
'***********************Replace Picture******************************************
'Arjun Port T6296 CMK 1-459557143 040908 added Optional bNewInstance = False
Public Sub ReplacePicture(Optional NewPicture As String, Optional OldPicture As String, Optional TagGroupFileName As String, Optional intErrorMode As Integer = 0, Optional bShowPictureNotOpenErrors As Boolean = False, Optional CallingPictureObject As Object = Nothing, Optional TSPicType As TS_PIC_TYPE = -1, Optional TagList As Variant = Nothing, Optional bNewInstance As Boolean = False)
'Public Sub ReplacePicture(Optional NewPicture As String, Optional OldPicture As String, Optional TagGroupFileName As String, Optional intErrorMode As Integer = 0, Optional bShowPictureNotOpenErrors As Boolean = False, Optional CallingPictureObject As Object = Nothing, Optional TSPicType As TS_PIC_TYPE = -1, Optional TagList As Variant = Nothing)
'Public Sub ReplacePicture(NewPicture As String, Optional OldPicture As String, Optional TagGroupFileName As String, Optional intErrorMode As Integer = 0, Optional bShowPictureNotOpenErrors As Boolean = False)
Dim AppObj As Object
Dim PictureObj As Object
Dim i As Integer
Dim aliascount As Integer
Dim strFileFound As String
Dim SaveOldPicture As String 'Arjun Port T6296 CMK 1-459557143 040908
Dim SaveNewPicture As String 'Arjun Port T6296 CMK 1-459557143 040908
If intErrorMode <> 1 Then
On Error GoTo ErrorHandler
End If
' Is this script running in the workspace or background
If TypeName(Application) = "CFixApp" Then
' running in the workspace
Set AppObj = Application
Else
' running in the background
' see if we can get the workspace object
Set AppObj = App
If AppObj Is Nothing Then
Exit Sub
End If
End If
'If user enters nothing for OldPicture meaning: replace the current picture in run mode with NewPicture then:
If OldPicture = "" Then
Set PictureObj = AppObj.ActiveDocument
GoTo NewPictureCheck
End If
'Arjun Port T6296 CMK 1-459557143 040908 check to see if false, this way we test to see if the new
'picture and old picture are the same names. If so, then we want to error, similiar
'to the way we did in did in previous version prior to new picture instancing
If bNewInstance = False Then
If NewPicture <> "" And OldPicture <> "" Then
SaveOldPicture = OldPicture
SaveNewPicture = NewPicture
SaveOldPicture = ParsePictureName(SaveOldPicture)
SaveNewPicture = ParsePictureName(SaveNewPicture)
If (StrComp(SaveOldPicture, SaveNewPicture, vbTextCompare) = 0) Then
GoTo PictureAlreadyOpen
End If
End If
End If
'CMK 1-459557143 040908
'If the user specifies a particular picture to replace with NewPicture
'check for a "\" in the Picture to replace
If InStr(1, OldPicture, "\", vbTextCompare) <> 0 Then
'if there is a "\" check to see if the file extension is also supplied. If it isn't, add on the .grf extension
If InStr(1, OldPicture, ".", vbTextCompare) = 0 Then
OldPicture = OldPicture & ".grf"
'If the file extension is supplied, make sure it is .grf. Otherwise, send a message.
ElseIf InStr(1, OldPicture, "grf", vbTextCompare) = 0 Then
'JPB052303 Tracker #61 show error, but only if user indicated so
If bShowPictureNotOpenErrors = True Then
GoTo NoSuchOldPicture
End If
End If
'If the file is open, do the replace
For Each PictureObj In AppObj.Documents
If TypeName(PictureObj.ActiveWindow) <> "Nothing" Then
If InStr(1, OldPicture, PictureObj.FileName, vbTextCompare) Then
GoTo NewPictureCheck
End If
End If
Next
'JPB052303 Tracker #61 show error, but only if user indicated so
If bShowPictureNotOpenErrors = True Then
GoTo NoSuchOldPicture
End If
Exit Sub
'if a path is not specified for the old picture
Else
If InStr(1, OldPicture, ".", vbTextCompare) = 0 Then
'See if it is an alias
aliascount = 0
For Each PictureObj In AppObj.Documents
If TypeName(PictureObj.ActiveWindow) <> "Nothing" Then
If UCase(OldPicture) = UCase(PictureObj.ActiveWindow.WindowName) Then
GoTo NewPictureCheck
aliascount = aliascount + 1
End If
If aliascount > 0 Then
Exit Sub
End If
End If
Next
'add on a .grf
OldPicture = OldPicture & ".grf"
End If
For Each PictureObj In AppObj.Documents
If TypeName(PictureObj.ActiveWindow) <> "Nothing" Then
If UCase(PictureObj.FileName) = UCase(OldPicture) Then
GoTo NewPictureCheck
End If
End If
Next
'JPB052303 Tracker #61 show error, but only if user indicated so
If bShowPictureNotOpenErrors = True Then
GoTo NoSuchOldPicture
End If
Exit Sub
End If
NewPictureCheck:
'See if the user supplied the full path for NewPicture
If NewPicture <> "" Then
If InStr(1, NewPicture, "\", vbTextCompare) <> 0 Then
'If it is supplied, check to see if the file's extension is supplied. If it is not, add on .grf
If InStr(1, NewPicture, ".", vbTextCompare) = 0 Then
NewPicture = NewPicture & ".grf"
'If it is, check to make sure it is a .grf type file
ElseIf InStr(1, NewPicture, "grf", vbTextCompare) = 0 Then
GoTo NoSuchNewPicture
End If
'Check to see if file actually exists. If it doesn't exist, display a message. If it does, replace current picture.
If Dir(NewPicture) = "" Then
GoTo NoSuchNewPicture
Else
If TagGroupFileName = "" Then
'PictureObj.ActiveWindow.ReplaceDocument (NewPicture)
' Naveen 09/22/09 : Added a new method to take care of single instance
PictureObj.ActiveWindow.ReplaceDocument3 NewPicture, bNewInstance
Else
' does the file exist
strFileFound = GetFullFilePath(TagGroupFileName, System.picturepath, ".tgd")
If strFileFound = "" Then ' not found
Err.Raise 53, , NLSStrMgr.GetNLSStr(1025, TagGroupFileName)
Exit Sub
End If
'PictureObj.ActiveWindow.ReplaceDocument2 NewPicture, TagGroupFileName
' Naveen 09/22/09 : Added a new method to take care of single instance
PictureObj.ActiveWindow.ReplaceDocument3 NewPicture, bNewInstance, TagGroupFileName
End If
End If
' if there is no "\" in NewPicture string, the user did not specify the full path. Check if they supplied the extension.
Else
If InStr(1, NewPicture, ".", vbTextCompare) = 0 Then
'add on ".grf" to the file name
NewPicture = NewPicture & ".grf"
'If an extension is supplied, check if it is .grf
ElseIf InStr(1, NewPicture, "grf", vbTextCompare) = 0 Then
GoTo NoSuchNewPicture
End If
'Add the fix Pic path to the filename
'eaj012800 Use the old picture's path instead of pic path, this was added for iViusalize
'lad 032602 Tracker #3029 port jes112701 changed PictureObj.path to PictureObj.Path
'NewPicture = System.picturepath & "\" & NewPicture
NewPicture = PictureObj.Path & "\" & NewPicture
If Dir(NewPicture) = "" Then
GoTo NoSuchNewPicture
Else
If TagGroupFileName = "" Then
'PictureObj.ActiveWindow.ReplaceDocument (NewPicture)
' Naveen 09/22/09 : Added a new method to take care of single instance
PictureObj.ActiveWindow.ReplaceDocument3 NewPicture, bNewInstance
Else
' does the file exist
strFileFound = GetFullFilePath(TagGroupFileName, System.picturepath, ".tgd")
If strFileFound = "" Then ' not found
Err.Raise 53, , NLSStrMgr.GetNLSStr(1025, TagGroupFileName)
Exit Sub
End If
'PictureObj.ActiveWindow.ReplaceDocument2 NewPicture, TagGroupFileName
' Naveen 09/22/09 : Added a new method to take care of single instance
PictureObj.ActiveWindow.ReplaceDocument3 NewPicture, bNewInstance, TagGroupFileName
End If
End If
End If
Else ' NewPicture was NOT supplied. Check for tag status functionality
If CallingPictureObject Is Nothing Then
Exit Sub
End If
If TSPicType = NONE Then
Exit Sub
End If
If TypeName(CallingPictureObject) <> "CFixPicture" Then
Exit Sub
End If
' All checks passed, do a replace with a tag status picture
Dim TypeNameString As String
TypeNameString = TypeName(TagList)
If (TypeNameString = "String()") Then ' Pass a taglist to open_pic
CallingPictureObject.Replace_TS_Pic_Type TSPicType, TagList
Else
If TSPicType = TAGSTATUS Then
CallingPictureObject.Replace_TS_Pic
ElseIf TSPicType = QUICKTREND Then
CallingPictureObject.Replace_QT_Pic
ElseIf TSPicType = TAGCONTROLPANEL Then
CallingPictureObject.Replace_TCP_Pic
Else
Exit Sub ' Coming here indicates our checks up above were not sufficient since we should not be trying a tag status feature unless the TSPicType was set properly.
End If
End If
End If
Exit Sub
'Arjun Port 6296
PictureAlreadyOpen:
ErrorOption intErrorMode, ERR_NUM_PICALREADYOPEN, NLSStrMgr.GetNLSStr(1255, NewPicture)
Exit Sub
NoSuchOldPicture:
ErrorOption intErrorMode, ERR_NUM_PICNOTFOUND, NLSStrMgr.GetNLSStr(1024, OldPicture), OldPicture
Exit Sub
NoSuchNewPicture:
ErrorOption intErrorMode, ERR_NUM_PICNOTFOUND, NLSStrMgr.GetNLSStr(1024, NewPicture), OldPicture
Exit Sub
ErrorHandler:
'jtt05272003 Check for Security Failure, error already handled in the automation method
If Err.number = -2147196405 Then
Exit Sub
End If
If InStr(1, Err.Description, NLSStrMgr.GetNLSStr(1168), 1) Then
ErrorOption intErrorMode, Err.number, Err.Description, OldPicture
Else
HandleError (intErrorMode)
End If
End Sub
'Arjun Port T6296 CMK 1-459557143 040808 This function to parses filename from path if the user supplied filename along with path
Public Function ParsePictureName(FileNameStr As String) As String
Dim iRetPos As Long
If InStr(1, FileNameStr, "\", vbTextCompare) <> 0 Then
iRetPos = InStrRev(FileNameStr, "\", Len(FileNameStr), vbTextCompare)
'FileNameStr = Left(FileNameStr, iRetPos)
FileNameStr = Right(FileNameStr, Len(FileNameStr) - iRetPos)
End If
If InStr(1, FileNameStr, ".", vbTextCompare) = 0 Then
'add on ".grf" to the file name
FileNameStr = FileNameStr & ".grf"
End If
ParsePictureName = FileNameStr
FileNameStr = ""
End Function
'**************************Close Picture*****************************************
Public Sub ClosePicture(Optional Picture As String, Optional intErrorMode As Integer = 0)
Dim AppObj As Object
Dim PictureDoc As Object
Dim i As Integer
Dim intAlias As Integer
Dim intStringIndex As Integer
Dim intFileNameStart As Integer
Dim strFilename As String
If intErrorMode <> 1 Then
On Error GoTo ErrorHandler
End If
' Is this script running in the workspace or background
If TypeName(Application) = "CFixApp" Then
' running in the workspace
Set AppObj = Application
Else
' running in the background
' see if we can get the workspace object
Set AppObj = App
If AppObj Is Nothing Then
Exit Sub
End If
End If
'If user enters nothing for Picture meaning: close the current picture in run mode then:
If Picture = "" Then
Set PictureDoc = AppObj.ActiveDocument
PictureDoc.Close
Exit Sub
End If
'If the user entered a picture file name, check to see if the full path is supplied by checking for a "\" in the string.
intStringIndex = InStr(1, Picture, "\", vbTextCompare)
If intStringIndex <> 0 Then
'If it is supplied, check to see if the file's extension is supplied.
If InStr(1, Picture, ".", vbTextCompare) = 0 Then
'add .grf onto the file name.
Picture = Picture & ".grf"
'If the file extension is supplied, make sure it is ".grf". If it is not, go to the NoSuchPicture message.
ElseIf InStr(1, Picture, "grf", vbTextCompare) = 0 Then
GoTo NoSuchPicture
End If
'Check to see if this file actually exists.
If Dir(Picture) = "" Then
GoTo NoSuchPicture
End If
intFileNameStart = intStringIndex
strFilename = Picture
While intStringIndex <> 0
intStringIndex = InStr(intFileNameStart + 1, Picture, "\", vbTextCompare)
If intStringIndex <> 0 Then
intFileNameStart = intStringIndex
End If
Wend
strFilename = Mid(Picture, intFileNameStart + 1)
For Each PictureDoc In AppObj.Documents
If TypeName(PictureDoc.ActiveWindow) <> "Nothing" Then
If StrComp(strFilename, PictureDoc.FileName, vbTextCompare) = 0 Then
PictureDoc.Close
End If
End If
Next
Exit Sub
'If there is no "\" in the Picture string, the user did not specify the full path. Chck to see if the user supplied an extension.
Else
If InStr(1, Picture, ".", vbTextCompare) = 0 Then
'The entry may be an alias
intAlias = 0
For Each PictureDoc In AppObj.Documents
If TypeName(PictureDoc.ActiveWindow) <> "Nothing" Then
If UCase(PictureDoc.ActiveWindow.WindowName) = UCase(Picture) Then
PictureDoc.Close
intAlias = intAlias + 1
End If
End If
Next
If intAlias > 0 Then
Exit Sub
End If
'add on .grf
Picture = Picture & ".grf"
ElseIf InStr(1, Picture, "grf", vbTextCompare) = 0 Then
GoTo NoSuchPicture
Exit Sub
End If
strFilename = Picture
'Add the Fix Pic path to the file name
Picture = System.picturepath & "\" & Picture
If Dir(Picture) = "" Then
GoTo NoSuchPicture
End If
For Each PictureDoc In AppObj.Documents
If TypeName(PictureDoc.ActiveWindow) <> "Nothing" Then
If StrComp(strFilename, PictureDoc.FileName, vbTextCompare) = 0 Then
PictureDoc.Close
End If
End If
Next
End If
Exit Sub
NoSuchPicture:
ErrorOption intErrorMode, ERR_NUM_PICNOTFOUND, NLSStrMgr.GetNLSStr(1024, Picture)
Exit Sub
ErrorHandler:
HandleError (intErrorMode)
End Sub
'*****************************Toggle Digital Point*******************************
'kei03062008 iFix4.7 Added bSendMsg option
Public Sub ToggleDigitalPoint(Optional DigitalPoint As String, Optional intErrorMode As Integer = 0, Optional bSendMsg As Boolean = True)
Dim AppObj As Object
Dim DigitalPointObj As Object
Dim PictureObj As Object
Dim SelObj As Object
Dim strDataSource As String
Dim lStatus As Long
Dim ValidDataSourceObj As Object
Dim strPropertyName As String
'jrc022499 Tag Group Support
Dim strSub As String
Dim bPerformWrite As Boolean
'lad032802 Tracker #2672
Dim strField, strFullyQualName As String
Dim intCompare, intPos, intLen, intField As Integer
'lad040302 Tracker #3293
Dim intCurrentValue As Integer
If intErrorMode <> 1 Then
On Error GoTo ErrorHandler
End If
'If the user entered "" in the call to ToggleDigitalPoint and wants to toggle the digital point
'for the currently selected item in run mode, set DigitalPoint equal to the name of the data source
'for the currently selected item.
If DigitalPoint = "" Then
'If the routine is called from the background task, we can't perform the operation.
Dim strDocType As String
GetActiveDocType strDocType
' activedoctype returns nothing if no pictures open or in background task
If strDocType = "Nothing" Then
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1026)
End If
Exit Sub
End If
Set PictureObj = Application.ActiveDocument.page
'If the routine is called from a schedule, we can't perform the operation without a defined point.
If PictureObj.ClassName = "Scheduler" Then
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1026)
End If
Exit Sub
End If
Set SelObj = PictureObj.SelectedShapes
If SelObj.Count = 0 Then
ErrorOption intErrorMode, ERR_NUM_NOOBJECTSELECTEDFORROUTINE, NLSStrMgr.GetNLSStr(1169)
End
End If
For Each SelObj In PictureObj.SelectedShapes
strDataSource = FindDataSource(SelObj, "")
If strDataSource = "" Then
ErrorOption intErrorMode, ERR_NUM_NOCONNECTIONTODATASOURCE, NLSStrMgr.GetNLSStr(1170, SelObj.Name)
Exit Sub
End If
PictureObj.TagGroupSubstitution strDataSource, strSub
Set DigitalPointObj = System.FindObject(strSub)
If (TypeName(DigitalPointObj) = "Nothing") Then
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1171, SelObj.Name, Chr(13), strSub)
Exit Sub
End If
strPropertyName = DigitalPointObj.FullyQualifiedName
'lad032802 Tracker#2672
strFullyQualName = strPropertyName
DigitalPointObj.ValidateSource strPropertyName, lStatus, ValidDataSourceObj, strPropertyName
If lStatus <> 0 Then
GoTo StatusHandler
End If
'lad032802 Tracker#2672 we don't support A_ fields for ToggleDigitalPoint, so
'if this is one, warn the user and get out
'05/06/2008 Priya Port thc022908 skip the "A" field check check if not an iFix tag
If Not InStr(1, UCase(strFullyQualName), "FIX32.", 1) = 0 Then
'lad032802 Tracker#2672 we don't support A_ fields for ToggleDigitalPoint, so
'if this is one, warn the user and get out
intPos = InStrRev(strFullyQualName, ".", -1, vbTextCompare)
intLen = Len(strFullyQualName)
intField = intLen - intPos
strField = Right(strFullyQualName, intField)
strField = Left(strField, 1)
intCompare = StrComp(strField, "A")
If intCompare <> 0 Then
intCompare = StrComp(strField, "a")
End If
If intCompare = 0 Then
ErrorOption intErrorMode, ERR_NUM_DATASOURCEDATATYPEMISMATCH, NLSStrMgr.GetNLSStr(1174, Chr(13), strDataSource)
End
End If
End If
'lad040302 Tracker #3293 - round the value befor we do the compare to 1
'kei052808 iFix5.0 #5711: thc060107 1-257039001 (1) Check if value is boolean and convert to integer 0 or 1 before comparison
If VarType(ValidDataSourceObj.Value) = vbBoolean Then
If ValidDataSourceObj.Value = False Then
intCurrentValue = 0
Else
intCurrentValue = 1
End If
Else
intCurrentValue = Round(ValidDataSourceObj.Value)
End If
If intCurrentValue = 0 Then
ShowESignatureDlg PictureObj, strFullyQualName, 1, False, bPerformWrite, "", "", intErrorMode
If bPerformWrite = True Then
ValidDataSourceObj.Value = 1
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1030, ValidDataSourceObj.FullyQualifiedName), ValidDataSourceObj.FullyQualifiedName
End If
End If
ElseIf intCurrentValue = 1 Then
ShowESignatureDlg PictureObj, strFullyQualName, 0, False, bPerformWrite, "", "", intErrorMode
If bPerformWrite = True Then
ValidDataSourceObj.Value = 0
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1031, ValidDataSourceObj.FullyQualifiedName), ValidDataSourceObj.FullyQualifiedName
End If
End If
'Include this Else statement so that if the value of the database point is not 0 or 1,
'meaning it is not a digital database point, the correct error message,
'"Current Block mode does not allow writes." gets launched. This will happen when we
'try to write a value to the point.
'lad022802 Tracker #2672 - don't write anything(it might succeed) - just display an error
Else
'ShowESignatureDlg PictureObj, strSub, 0, False, bPerformWrite, "", "", intErrorMode
'If bPerformWrite = True Then
'ValidDataSourceObj.Value = 0
'End If
ErrorOption intErrorMode, ERR_NUM_DATASOURCEDATATYPEMISMATCH, NLSStrMgr.GetNLSStr(1174, Chr(13), strDataSource)
End
End If
NextObject:
Next
'If the user entered a specific digital point when calling ToggleDigitalPoint
Else
'jlk031999 The FixBackgroundServer does not support ActiveDocument
GetActiveDocType strDocType
' activedoctype returns nothing if no pictures open or in background task
If strDocType <> "Nothing" Then
Set PictureObj = Application.ActiveDocument.page
'jrc
PictureObj.TagGroupSubstitution DigitalPoint, strSub
Else
strSub = DigitalPoint
End If
On Error GoTo FindObjectError
Set DigitalPointObj = System.FindObject(strSub)
strPropertyName = DigitalPointObj.FullyQualifiedName
'lad 032802 Tracker #2672
strFullyQualName = strPropertyName
DigitalPointObj.ValidateSource strPropertyName, lStatus, ValidDataSourceObj, strPropertyName
If lStatus <> 0 Then
GoTo StatusHandler
End If
'lad032802 Tracker#2672 we don't support A_ fields for ToggleDigitalPoint, so
'if this is one, warn the user and get out
'05/08/2008 Priya Port thc022908 skip the "A" field check check if not an iFix tag
If Not InStr(1, UCase(strFullyQualName), "FIX32.", 1) = 0 Then
'lad032802 Tracker#2672 we don't support A_ fields for ToggleDigitalPoint, so
'if this is one, warn the user and get out
intPos = InStrRev(strFullyQualName, ".", -1, vbTextCompare)
intLen = Len(strFullyQualName)
intField = intLen - intPos
strField = Right(strFullyQualName, intField)
strField = Left(strField, 1)
intCompare = StrComp(strField, "A")
If intCompare <> 0 Then
intCompare = StrComp(strField, "a")
End If
If intCompare = 0 Then
ErrorOption intErrorMode, ERR_NUM_DATASOURCEDATATYPEMISMATCH, NLSStrMgr.GetNLSStr(1174, Chr(13), DigitalPoint)
End
End If
End If
'lad040302 - Tracker #3293 - round the value befor we do the compare
'kei052808 iFix5.0 #5711: thc060107 1-257039001 (2) Check if value is boolean and convert to integer 0 or 1 before comparison
If VarType(ValidDataSourceObj.Value) = vbBoolean Then
If ValidDataSourceObj.Value = False Then
intCurrentValue = 0
Else
intCurrentValue = 1
End If
Else
intCurrentValue = Round(ValidDataSourceObj.Value)
End If
If intCurrentValue = 0 Then
ShowESignatureDlg PictureObj, strFullyQualName, 1, False, bPerformWrite, "", "", intErrorMode
If bPerformWrite = True Then
ValidDataSourceObj.Value = 1
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1030, ValidDataSourceObj.FullyQualifiedName), ValidDataSourceObj.FullyQualifiedName
End If
End If
ElseIf intCurrentValue = 1 Then
ShowESignatureDlg PictureObj, strFullyQualName, 0, False, bPerformWrite, "", "", intErrorMode
If bPerformWrite = True Then
ValidDataSourceObj.Value = 0
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1031, ValidDataSourceObj.FullyQualifiedName), ValidDataSourceObj.FullyQualifiedName
End If
End If
'Include this Else statement so that if the value of the database point is not 0 or 1,
'meaning it is not a digital database point, the correct error message,
'"Current Block mode does not allow writes." gets launched. This will happen when we
'try to write a value to the point.
'lad022702 Tracker#2672 don't write anything( it might succeed!) - just display an error and get out
Else
'ShowESignatureDlg PictureObj, strSub, 0, False, bPerformWrite, "", "", intErrorMode
'If bPerformWrite = True Then
' ValidDataSourceObj.Value = 0
'End If
ErrorOption intErrorMode, ERR_NUM_DATASOURCEDATATYPEMISMATCH, NLSStrMgr.GetNLSStr(1174, Chr(13), DigitalPoint)
End
End If
End If
Exit Sub
StatusHandler:
Select Case lStatus
Case 1
ErrorOption intErrorMode, ERR_NUM_DATASOURCEINVALIDSYNTAX, NLSStrMgr.GetNLSStr(1172, Chr(13), strSub)
Case 2
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1173, Chr(13), strSub)
Case 3
ErrorOption intErrorMode, ERR_NUM_DATASOURCEDATATYPEMISMATCH, NLSStrMgr.GetNLSStr(1174, Chr(13), strSub)
End Select
Exit Sub
'If FindObject fails when the user specifies just one datapoint
FindObjectError:
'data source is undefined
If Err.number = -2147200630 Then
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1173, Chr(13), strSub)
'Field Values are unknown
' ElseIf Err.number = -2147352567 Then
' ErrorOption intErrorMode, ERR_NUM_FIELDVALUESUNKNOWN, NLSStrMgr.GetNLSStr(1175, Chr(13), strSub)
Else
ErrorOption intErrorMode, Err.number, Err.Description
End If
Exit Sub
ErrorHandler:
'If FindObject fails when the user allows multiple selections
If Err.number = -2147352567 Then
HandleError intErrorMode
Resume NextObject
ElseIf Err.number = -2147200630 Then
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1173, Chr(13), strSub)
Resume NextObject
Else
HandleError (intErrorMode)
End If
End Sub
'***************************Open Digital Point********************************
'kei03062008 iFix4.7 Added bSendMsg option
Public Sub OpenDigitalPoint(Optional DigitalPoint As String, Optional intErrorMode As Integer = 0, Optional bSendMsg As Boolean = True)
Dim AppObj As Object
Dim DigitalPointObj As Object
Dim lStatus As Long
Dim ValidDataSourceObj As Object
Dim strPropertyName As String
Dim PictureObj As Object
Dim SelObj As Object
Dim strDataSource As String
'jrc
Dim strSub As String
Dim bPerformWrite As Boolean
If intErrorMode <> 1 Then
On Error GoTo ErrorHandler
End If
'If the user entered "" in the call to OpentDigitalPoint and wants to open the digital point
'for the currently selected item in run mode, set DigitalPoint equal to the name of the data source
'for the currently selected item.
If DigitalPoint = "" Then
'If this routine is called from the background task, the user must enter a tag
Dim strDocType As String
GetActiveDocType strDocType
' activedoctype returns nothing if no pictures open or in background task
If strDocType = "Nothing" Then
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1037)
End If
Exit Sub
End If
Set PictureObj = Application.ActiveDocument.page
'If this routine is called from a schedule, the user must enter a tag
If PictureObj.ClassName = "Scheduler" Then
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1037)
End If
Exit Sub
End If
Set SelObj = PictureObj.SelectedShapes
If SelObj.Count = 0 Then
ErrorOption intErrorMode, ERR_NUM_NOOBJECTSELECTEDFORROUTINE, NLSStrMgr.GetNLSStr(1176)
End
End If
For Each SelObj In PictureObj.SelectedShapes
strDataSource = FindDataSource(SelObj, "")
If strDataSource = "" Then
ErrorOption intErrorMode, ERR_NUM_NOCONNECTIONTODATASOURCE, NLSStrMgr.GetNLSStr(1170, SelObj.Name)
Exit Sub
End If
'jrc
PictureObj.TagGroupSubstitution strDataSource, strSub
Set DigitalPointObj = System.FindObject(strSub)
If (TypeName(DigitalPointObj) = "Nothing") Then
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1171, SelObj.Name, Chr(13), strSub)
Exit Sub
End If
strPropertyName = DigitalPointObj.FullyQualifiedName
DigitalPointObj.ValidateSource strPropertyName, lStatus, ValidDataSourceObj, strPropertyName
If lStatus <> 0 Then
GoTo StatusHandler
End If
'lad 042202 Tracker #3507 - use fully qualified name
ShowESignatureDlg PictureObj, DigitalPointObj.FullyQualifiedName, 0, False, bPerformWrite, "", "", intErrorMode
If bPerformWrite = True Then
ValidDataSourceObj.Value = 0
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1031, ValidDataSourceObj.FullyQualifiedName), ValidDataSourceObj.FullyQualifiedName
End If
End If
NextObject:
Next
Else
'jlk031999 The FixBackgroundServer does not support ActiveDocument
GetActiveDocType strDocType
' activedoctype returns nothing if no pictures open or in background task
If strDocType <> "Nothing" Then
Set PictureObj = Application.ActiveDocument.page
'jrc
PictureObj.TagGroupSubstitution DigitalPoint, strSub
Else
strSub = DigitalPoint
End If
On Error GoTo FindObjectError
Set DigitalPointObj = System.FindObject(strSub)
strPropertyName = DigitalPointObj.FullyQualifiedName
DigitalPointObj.ValidateSource strPropertyName, lStatus, ValidDataSourceObj, strPropertyName
If lStatus <> 0 Then
GoTo StatusHandler
End If
'lad 042202 Tracker #3507 - use fully qualified name
ShowESignatureDlg PictureObj, DigitalPointObj.FullyQualifiedName, 0, False, bPerformWrite, "", "", intErrorMode
If bPerformWrite = True Then
ValidDataSourceObj.Value = 0
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1031, ValidDataSourceObj.FullyQualifiedName), ValidDataSourceObj.FullyQualifiedName
End If
End If
End If
Exit Sub
StatusHandler:
Select Case lStatus
Case 1
ErrorOption intErrorMode, ERR_NUM_DATASOURCEINVALIDSYNTAX, NLSStrMgr.GetNLSStr(1177, Chr(13), strSub)
Case 2
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1178, Chr(13), strSub)
Case 3
ErrorOption intErrorMode, ERR_NUM_DATASOURCEDATATYPEMISMATCH, NLSStrMgr.GetNLSStr(1179, Chr(13), strSub)
End Select
Exit Sub
'If FindObject fails when the user specifies just one datapoint
FindObjectError:
'data source is undefined
If Err.number = -2147200630 Then
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1178, Chr(13), strSub)
'Field Values are unknown
' ElseIf Err.number = -2147352567 Then
' ErrorOption intErrorMode, ERR_NUM_FIELDVALUESUNKNOWN, NLSStrMgr.GetNLSStr(1180, Chr(13), strSub)
Else
ErrorOption intErrorMode, Err.number, Err.Description
End If
Exit Sub
ErrorHandler:
'If FindObject fails when the user allows multiple selections
If Err.number = -2147352567 Then
HandleError (intErrorMode)
Resume NextObject
ElseIf Err.number = -2147200630 Then
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1178, Chr(13), strSub)
Resume NextObject
Else
HandleError (intErrorMode)
End If
End Sub
'*****************************Close Digital Point*********************************
'kei03062008 iFix4.7 Added bSendMsg option
Public Sub CloseDigitalPoint(Optional DigitalPoint As String, Optional intErrorMode As Integer = 0, Optional bSendMsg As Boolean = True)
Dim AppObj As Object
Dim DigitalPointObj As Object
Dim lStatus As Long
Dim ValidDataSourceObj As Object
Dim strPropertyName As String
Dim PictureObj As Object
Dim SelObj As Object
Dim strDataSource As String
'jrc
Dim strSub As String
Dim bPerformWrite As Boolean
If intErrorMode <> 1 Then
On Error GoTo ErrorHandler
End If
'If the user entered "" in the call to OpentDigitalPoint and wants to open the digital point
'for the currently selected item in run mode, set DigitalPoint equal to the name of the data source
'for the currently selected item.
If DigitalPoint = "" Then
'If this routine is called from the background task, the user must enter a tag.
Dim strDocType As String
GetActiveDocType strDocType
' activedoctype returns nothing if no pictures open or in background task
If strDocType = "Nothing" Then
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1042)
End If
Exit Sub
End If
Set PictureObj = Application.ActiveDocument.page
'If this routine is called a schedule, the user must enter a tag.
If PictureObj.ClassName = "Scheduler" Then
If bSendMsg = True Then
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1042)
End If
End If
Exit Sub
End If
Set SelObj = PictureObj.SelectedShapes
If SelObj.Count = 0 Then
ErrorOption intErrorMode, ERR_NUM_NOOBJECTSELECTEDFORROUTINE, NLSStrMgr.GetNLSStr(1181)
End
End If
For Each SelObj In PictureObj.SelectedShapes
strDataSource = FindDataSource(SelObj, "")
If strDataSource = "" Then
ErrorOption intErrorMode, ERR_NUM_NOCONNECTIONTODATASOURCE, NLSStrMgr.GetNLSStr(1170, SelObj.Name)
Exit Sub
End If
'jrc
PictureObj.TagGroupSubstitution strDataSource, strSub
Set DigitalPointObj = System.FindObject(strSub)
If (TypeName(DigitalPointObj) = "Nothing") Then
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1171, SelObj.Name, Chr(13), strSub)
Exit Sub
End If
strPropertyName = DigitalPointObj.FullyQualifiedName
DigitalPointObj.ValidateSource strPropertyName, lStatus, ValidDataSourceObj, strPropertyName
If lStatus <> 0 Then
GoTo StatusHandler
End If
'lad 042202 Tracker #3507 - use fully qualified name
ShowESignatureDlg PictureObj, DigitalPointObj.FullyQualifiedName, 1, False, bPerformWrite, "", "", intErrorMode
If bPerformWrite = True Then
ValidDataSourceObj.Value = 1
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1030, DigitalPointObj.FullyQualifiedName), DigitalPointObj.FullyQualifiedName
End If
End If
NextObject:
Next
Else
'jlk031999 The FixBackgroundServer does not support ActiveDocument
GetActiveDocType strDocType
' activedoctype returns nothing if no pictures open or in background task
If strDocType <> "Nothing" Then
Set PictureObj = Application.ActiveDocument.page
'jrc
PictureObj.TagGroupSubstitution DigitalPoint, strSub
Else
strSub = DigitalPoint
End If
On Error GoTo FindObjectError
Set DigitalPointObj = System.FindObject(strSub)
strPropertyName = DigitalPointObj.FullyQualifiedName
DigitalPointObj.ValidateSource strPropertyName, lStatus, ValidDataSourceObj, strPropertyName
If lStatus <> 0 Then
GoTo StatusHandler
End If
'lad 042202 Tracker #3507 - use fully qualified name
ShowESignatureDlg PictureObj, DigitalPointObj.FullyQualifiedName, 1, False, bPerformWrite, "", "", intErrorMode
If bPerformWrite = True Then
ValidDataSourceObj.Value = 1
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1030, DigitalPointObj.FullyQualifiedName), DigitalPointObj.FullyQualifiedName
End If
End If
End If
Exit Sub
StatusHandler:
Select Case lStatus
Case 1
ErrorOption intErrorMode, ERR_NUM_DATASOURCEINVALIDSYNTAX, NLSStrMgr.GetNLSStr(1182, Chr(13), strSub)
Case 2
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1183, Chr(13), strSub)
Case 3
ErrorOption intErrorMode, ERR_NUM_DATASOURCEDATATYPEMISMATCH, NLSStrMgr.GetNLSStr(1184, Chr(13), strSub)
End Select
Exit Sub
FindObjectError:
'data source is undefined
If Err.number = -2147200630 Then
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1183, Chr(13), strSub)
'Field Values are unknown
' ElseIf Err.number = -2147352567 Then
' ErrorOption intErrorMode, ERR_NUM_FIELDVALUESUNKNOWN, NLSStrMgr.GetNLSStr(1185, Chr(13), strSub)
Else
ErrorOption intErrorMode, Err.number, Err.Description
End If
Exit Sub
ErrorHandler:
'If FindObject fails when the user allows multiple selections
If Err.number = -2147352567 Then
HandleError intErrorMode
Resume NextObject
ElseIf Err.number = -2147200630 Then
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1183, Chr(13), strSub)
Resume NextObject
Else
HandleError (intErrorMode)
End If
End Sub
'************************Acknowledge An Alarm*******************************
'kei03062008 iFix4.7 Added bSendMsg option
Public Sub AcknowledgeAnAlarm(Optional DataPoint As String, Optional intErrorMode As Integer = 0, Optional bSendMsg As Boolean = True)
Dim AppObj As Object
Dim DataPointObj As Object
Dim SelObj As Object
Dim CurrentObj As Object
Dim strDataSource
Dim AlarmAckObj As Object
Dim PictureObj As Object
Dim lStatus As Long
Dim szDataSourceName As String
Dim vtResults
Dim vtAttributeNames
'jrc
Dim strSub As String
Dim bPerformWrite As Boolean
Dim bAlarmValue As Boolean
Dim lNode As Long
Dim lTag As Long
Dim lField As Long
Dim strTag As String
'lad 041902 Tracker #1746
Dim bAllowManualDelete As Boolean
Dim intPos As Integer
If intErrorMode <> 1 Then
On Error GoTo ErrorHandler
End If
'If the user entered "" in the call to Acknowledge An Alarm and wants to acknowledge an alarm
'for the currently selected item in run mode, set the data source equal to the name of the data source
'for the currently selected item.
If DataPoint = "" Then
'If this routine is called by the background task, the user must enter a tag.
Dim strDocType As String
GetActiveDocType strDocType
' activedoctype returns nothing if no pictures open or in background task
If strDocType = "Nothing" Then
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1047)
End If
Exit Sub
End If
Set PictureObj = Application.ActiveDocument.page
'If this routine is called by a schedule, the user must enter a tag.
If PictureObj.ClassName = "Scheduler" Then
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1047)
End If
Exit Sub
End If
Set SelObj = PictureObj.SelectedShapes
If SelObj.Count = 0 Then
ErrorOption intErrorMode, ERR_NUM_NOOBJECTSELECTEDFORROUTINE, NLSStrMgr.GetNLSStr(1186)
End
End If
'For each object in the selected objects list
For Each CurrentObj In SelObj
Call GetAllConnections(CurrentObj)
Dim i As Integer
For Each strDataSource In AllConnectionsCollection
'If there is no valid object with the name strDataSource, tell the user that the data source assigned to
' the selected object does not yet exist.
On Error GoTo FindObjectError
'jrc
PictureObj.TagGroupSubstitution strDataSource, strSub
Set DataPointObj = System.FindObject(strSub)
'Get the Acknowledge Alarm Property attribute for the source.
'hj072205 Should use strSub instead of strDataSource so that the data source using a TAGGROUP symbol can work as well
'DataPointObj.GetPropertyAttributes strDataSource, 6, vtResults, vtAttributeNames, lStatus
DataPointObj.GetPropertyAttributes strSub, 6, vtResults, vtAttributeNames, lStatus
'If the status for the AcknowledgeAlarm attribute is 1 - Invalid syntax, 2 - Undefined Object, 3 - DataType mismatch, notify
' the user
If lStatus <> 0 Then
GoTo StatusHandler
End If
strDataSource = vtAttributeNames(0)
Set AlarmAckObj = System.FindObject(strDataSource)
bAlarmValue = AlarmAckObj.Value
If bAlarmValue <> False Then
ShowESignatureDlg PictureObj, CStr(strDataSource), False, True, bPerformWrite, "", "", intErrorMode
If bPerformWrite = True Then
AlarmAckObj.Value = False
' jjd - silence the horn whenever an alarm is acked.
System.SilenceAlarmHorn
lNode = InStr(1, strDataSource, ".", vbTextCompare)
lTag = InStr(lNode + 1, strDataSource, ".", vbTextCompare)
lField = InStr(lTag + 1, strDataSource, ".", vbTextCompare)
strTag = Mid(strDataSource, lTag + 1, lField - lTag - 1)
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1049, strTag), AlarmAckObj.FullyQualifiedName
End If
End If
'lad 041902 Tracker #1746 - handle manual alarm deletion
Else
System.FixGetManualAlmDeleteEnabled bAllowManualDelete
If bAllowManualDelete <> 0 Then
intPos = InStrRev(strDataSource, ".", -1, vbTextCompare)
'hj070903 Should not change the string value of passed-in parameter DataPoint.
'Instead, use local variable strDataSource to keep the new string.
strDataSource = Left(strDataSource, intPos)
strDataSource = strDataSource & "b_dalm"
On Error GoTo FindObjectError
Set AlarmAckObj = System.FindObject(strDataSource)
bAlarmValue = AlarmAckObj.Value
If bAlarmValue = False Then
ShowESignatureDlg PictureObj, CStr(strDataSource), True, True, bPerformWrite, "", "", intErrorMode
If bPerformWrite = True Then
On Error GoTo IllegalAlmStateError
AlarmAckObj.Value = 1
lNode = InStr(1, strDataSource, ".", vbTextCompare)
lTag = InStr(lNode + 1, strDataSource, ".", vbTextCompare)
lField = InStr(lTag + 1, strDataSource, ".", vbTextCompare)
strTag = Mid(strDataSource, lTag + 1, lField - lTag - 1)
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(2009, strTag), strDataSource
End If
End If
End If
End If
End If
Next
NextObject:
Next
Exit Sub
'If user specified a specific datapoint to acknowledge alarm on
Else
'jlk031999 The FixBackgroundServer does not support ActiveDocument
GetActiveDocType strDocType
' activedoctype returns nothing if no pictures open or in background task
If strDocType <> "Nothing" Then
Set PictureObj = Application.ActiveDocument.page
'jrc
PictureObj.TagGroupSubstitution DataPoint, strSub
Else
strSub = DataPoint
End If
On Error GoTo FindObjectError
Set DataPointObj = System.FindObject(strSub)
strDataSource = DataPointObj.FullyQualifiedName
DataPointObj.GetPropertyAttributes strDataSource, 6, vtResults, vtAttributeNames, lStatus
'If the status for the AcknowledgeAlarm attribute is 1 - Invalid syntax, 2 - Undefined Object, 3 - DataType mismatch, notify
' the user
If lStatus <> 0 Then
GoTo StatusHandler
End If
'hj070903 Should not change the string value of passed-in parameter DataPoint.
'Instead, use local variable strDataSource to keep the new string.
strDataSource = vtAttributeNames(0)
On Error GoTo FindObjectError
Set AlarmAckObj = System.FindObject(strDataSource)
bAlarmValue = AlarmAckObj.Value
If bAlarmValue <> False Then
ShowESignatureDlg PictureObj, CStr(strDataSource), False, True, bPerformWrite, "", "", intErrorMode
If bPerformWrite = True Then
AlarmAckObj.Value = False
' jjd - silence the alarm horn whenever an alarm is acked.
System.SilenceAlarmHorn
lNode = InStr(1, strDataSource, ".", vbTextCompare)
lTag = InStr(lNode + 1, strDataSource, ".", vbTextCompare)
lField = InStr(lTag + 1, strDataSource, ".", vbTextCompare)
strTag = Mid(strDataSource, lTag + 1, lField - lTag - 1)
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1049, strTag), AlarmAckObj.FullyQualifiedName
End If
End If
'lad 041902 Tracker #1746 - handle manual alarm deletion
Else
System.FixGetManualAlmDeleteEnabled bAllowManualDelete
If bAllowManualDelete <> 0 Then
'hj070903 Should not change the string value of passed-in parameter DataPoint.
'Instead, use local variable strDataSource to keep the new string.
strDataSource = Left(strDataSource, intPos)
strDataSource = strDataSource & "b_dalm"
On Error GoTo FindObjectError
Set AlarmAckObj = System.FindObject(strDataSource)
bAlarmValue = AlarmAckObj.Value
If bAlarmValue = False Then
ShowESignatureDlg PictureObj, CStr(strDataSource), True, True, bPerformWrite, "", "", intErrorMode
If bPerformWrite = True Then
On Error GoTo IllegalAlmStateError1
AlarmAckObj.Value = 1
lNode = InStr(1, strDataSource, ".", vbTextCompare)
lTag = InStr(lNode + 1, strDataSource, ".", vbTextCompare)
lField = InStr(lTag + 1, strDataSource, ".", vbTextCompare)
strTag = Mid(strDataSource, lTag + 1, lField - lTag - 1)
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(2009, strTag), strDataSource
End If
End If
End If
End If
End If
End If
Exit Sub
StatusHandler:
Select Case lStatus
Case 1
ErrorOption intErrorMode, ERR_NUM_DATASOURCEINVALIDSYNTAX, NLSStrMgr.GetNLSStr(1187, Chr(13), strSub)
Case 2
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1188, Chr(13), strSub)
Case 3
ErrorOption intErrorMode, ERR_NUM_DATASOURCEDATATYPEMISMATCH, NLSStrMgr.GetNLSStr(1189, Chr(13), strSub)
End Select
Exit Sub
IllegalAlmStateError:
'lad 041902 Tracker #1746
'if an illegal alarm state error is returned when we try to remove an alarm - move on to the next selected object
If Err.number = -2147187023 Then
Resume NextObject
Else
HandleError (intErrorMode)
End If
IllegalAlmStateError1:
'lad 041902 Tracker #1746
'if an illegal alarm state error is returned when we try to remove an alarm - this is a single alarm so we're done
If Err.number = -2147187023 Then
Exit Sub
Else
HandleError (intErrorMode)
End If
'If FindObject fails when the user specifies just one datapoint'If FindObject fails when the user specifies just one datapoint
FindObjectError:
'data source is undefined
If Err.number = -2147200630 Then
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1188, Chr(13), strSub)
'Field Values are unknown
' ElseIf Err.number = -2147352567 Then
' ErrorOption intErrorMode, ERR_NUM_FIELDVALUESUNKNOWN, NLSStrMgr.GetNLSStr(1190, Chr(13), strSub)
Else
ErrorOption intErrorMode, Err.number, Err.Description
End If
Exit Sub
ErrorHandler:
'If FindObject fails when the user allows multiple selections
If Err.number = -2147352567 Then
HandleError intErrorMode
Resume NextObject
ElseIf Err.number = -2147200630 Then
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1188, Chr(13), strSub)
Resume NextObject
Else
HandleError (intErrorMode)
End If
End Sub
'********************************Ramp Value****************************************
'kei03062008 iFix4.7 Added bSendMsg option
Public Sub RampValue(RampValue As Double, ByPercent As Boolean, Optional DataPoint As String, Optional intErrorMode As Integer = 0, Optional bSendMsg As Boolean = True)
Dim AppObj As Object
Dim DataPointObj As Object
Dim PictureObj As Object
Dim SelObj As Object
Dim strDataSource As String
Dim vtResults
Dim vtEGUNames
Dim lStatus As Long
Dim LoEGUObj As Object
Dim HiEGUObj As Object
Dim LoEGU As Double
Dim HiEGU As Double
Dim RampVal As Double
Dim X As Integer
' JLP050800 - This wasn't working with alternate data systems as a double
' The data type of a COPCDataItem Value property is a Variant, so we must get the type
'Dim val As Double
Dim val As Variant
Dim strType As String
'jrc
Dim strSub As String
Dim bPerformWrite As Boolean
If intErrorMode <> 1 Then
On Error GoTo ErrorHandler
End If
If DataPoint = "" Then
'If this routine is called from the background task, the user must enter a tag.
Dim strDocType As String
GetActiveDocType strDocType
' activedoctype returns nothing if no pictures open or in background task
If strDocType = "Nothing" Then
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1053)
End If
Exit Sub
End If
Set PictureObj = Application.ActiveDocument.page
'If this routine is called from the background task, the user must enter a tag.
If PictureObj.ClassName = "Scheduler" Then
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1053)
End If
Exit Sub
End If
Set SelObj = PictureObj.SelectedShapes
If SelObj.Count = 0 Then
ErrorOption intErrorMode, ERR_NUM_NOOBJECTSELECTEDFORROUTINE, NLSStrMgr.GetNLSStr(1191)
End
End If
For Each SelObj In PictureObj.SelectedShapes
strDataSource = FindDataSource(SelObj, "")
If strDataSource = "" Then
ErrorOption intErrorMode, ERR_NUM_NOCONNECTIONTODATASOURCE, NLSStrMgr.GetNLSStr(1170, SelObj.Name)
Exit Sub
End If
'jrc
PictureObj.TagGroupSubstitution strDataSource, strSub
Set DataPointObj = System.FindObject(strSub)
If (TypeName(DataPointObj) = "Nothing") Then
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1171, SelObj.Name, Chr(13), strSub)
Exit Sub
End If
'get LowEGU object
DataPointObj.GetPropertyAttributes DataPointObj.FullyQualifiedName, 2, vtResults, vtEGUNames, lStatus
' If vtResults comes back as empty, use the EGULimits (enum 9).
If lStatus = 0 Then
If TypeName(vtResults(0)) = "Empty" Then
DataPointObj.GetPropertyAttributes DataPointObj.FullyQualifiedName, 9, vtResults, vtEGUNames, lStatus
End If
End If
strDataSource = vtEGUNames(0)
On Error GoTo FindObjectError
Set LoEGUObj = System.FindObject(strDataSource)
LoEGU = LoEGUObj.Value
'get HighEGU object
strDataSource = vtEGUNames(1)
Set HiEGUObj = System.FindObject(strDataSource)
HiEGU = HiEGUObj.Value
If ByPercent Then
X = 100
'case #180970
'case #198667
RampVal = ((HiEGU - LoEGU) * RampValue) / X
Else
RampVal = RampValue
End If
val = DataPointObj.Value + RampVal
Select Case (val)
Case Is > HiEGU
val = HiEGU
Case Is < LoEGU
val = LoEGU
Case Else
' JLP050800 - We must cast the val into the correct data type
strType = TypeName(DataPointObj.Value)
Select Case UCase(strType)
Case ("SINGLE")
val = CSng(val)
Case ("LONG")
val = CLng(val)
Case ("INTEGER")
val = CInt(val)
Case Else
val = CDbl(val)
End Select
' End JLP050800
End Select
'lad 042202 Tracker #3507 - use fully qualified name
ShowESignatureDlg PictureObj, DataPointObj.FullyQualifiedName, val, False, bPerformWrite, "", "", intErrorMode
If bPerformWrite = True Then
DataPointObj.Value = val
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1055, DataPointObj.FullyQualifiedName, val), DataPointObj.FullyQualifiedName
End If
End If
NextObject:
Next
Else
'jlk031999 The FixBackgroundServer does not support ActiveDocument
GetActiveDocType strDocType
' activedoctype returns nothing if no pictures open or in background task
If strDocType <> "Nothing" Then
Set PictureObj = Application.ActiveDocument.page
'jrc
PictureObj.TagGroupSubstitution DataPoint, strSub
Else
strSub = DataPoint
End If
On Error GoTo FindObjectError
Set DataPointObj = System.FindObject(strSub)
'get LowEGU object
DataPointObj.GetPropertyAttributes DataPointObj.FullyQualifiedName, 2, vtResults, vtEGUNames, lStatus
' JLP050800 - Data Systems other than Fix32 may not have EGUs, have to handle it
If Not UCase(TypeName(vtEGUNames)) = "EMPTY" Then
'hj070903 Should not change the string value of passed-in parameter DataPoint.
'Instead, use local variable strDataSource to keep the new string.
strDataSource = vtEGUNames(0)
' JLP050800
'On Error GoTo FindObjectError
Set LoEGUObj = System.FindObject(strDataSource)
'If the datasource returns a digital point, it can't be ramped so exit the subroutine
'hj050602 - PBH 06/03/2003
'If InStr(1, DataPoint, NLSStrMgr.GetNLSStr(1192), vbTextCompare) <> 0 Or InStr(1, DataPoint, NLSStrMgr.GetNLSStr(1193), vbTextCompare) <> 0 Then
If InStr(1, strDataSource, NLSStrMgr.GetNLSStr(1192), vbTextCompare) <> 0 Or InStr(1, strDataSource, NLSStrMgr.GetNLSStr(1193), vbTextCompare) <> 0 Then
Exit Sub
End If
LoEGU = LoEGUObj.Value
Else
LoEGU = -65535
End If
'get HighEGU object
' JLP050800 - Data Systems other than Fix32 may not have EGUs, have to handle it
If Not UCase(TypeName(vtEGUNames)) = "EMPTY" Then
'hj070903 Should not change the string value of passed-in parameter DataPoint.
'Instead, use local variable strDataSource to keep the new string.
strDataSource = vtEGUNames(1)
' JLP050800
'On Error GoTo FindObjectError
Set HiEGUObj = System.FindObject(strDataSource)
'If the datasource returns a digital point, it can't be ramped so exit the subroutine
'hj050602 - PBH 06/03/2003
'If InStr(1, DataPoint, NLSStrMgr.GetNLSStr(1192), vbTextCompare) <> 0 Or InStr(1, DataPoint, NLSStrMgr.GetNLSStr(1193), vbTextCompare) <> 0 Then
If InStr(1, strDataSource, NLSStrMgr.GetNLSStr(1192), vbTextCompare) <> 0 Or InStr(1, strDataSource, NLSStrMgr.GetNLSStr(1193), vbTextCompare) <> 0 Then
Exit Sub
End If
HiEGU = HiEGUObj.Value
Else
HiEGU = 65535
End If
If ByPercent Then
X = 100
'case #180970
'case #198667
RampVal = ((HiEGU - LoEGU) * RampValue) / X
Else
RampVal = RampValue
End If
val = DataPointObj.Value + RampVal
Select Case (val)
Case Is > HiEGU
val = HiEGU
Case Is < LoEGU
val = LoEGU
Case Else
' JLP050800 - We must cast the val into the correct data type
strType = TypeName(DataPointObj.Value)
Select Case UCase(strType)
Case ("SINGLE")
val = CSng(val)
Case ("LONG")
val = CLng(val)
Case ("INTEGER")
val = CInt(val)
Case Else
val = CDbl(val)
End Select
' End JLP050800
End Select
'lad 042202 Tracker #3507 - use fully qualified name
ShowESignatureDlg PictureObj, DataPointObj.FullyQualifiedName, val, False, bPerformWrite, "", "", intErrorMode
If bPerformWrite = True Then
DataPointObj.Value = val
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1055, DataPointObj.FullyQualifiedName, val), DataPointObj.FullyQualifiedName
End If
End If
End If
Exit Sub
StatusHandler:
Select Case lStatus
Case 1
ErrorOption intErrorMode, ERR_NUM_DATASOURCEINVALIDSYNTAX, NLSStrMgr.GetNLSStr(1194, Chr(13), strSub)
Case 2
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1195, Chr(13), strSub)
Case 3
ErrorOption intErrorMode, ERR_NUM_DATASOURCEDATATYPEMISMATCH, NLSStrMgr.GetNLSStr(1196, Chr(13), strSub)
End Select
Exit Sub
'If FindObject fails when the user specifies just one datapoint
FindObjectError:
'data source is undefined
If Err.number = -2147200630 Then
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1195, Chr(13), strSub)
'Field Values are unknown
' ElseIf Err.number = -2147352567 Then
' ErrorOption intErrorMode, ERR_NUM_FIELDVALUESUNKNOWN, NLSStrMgr.GetNLSStr(1197, Chr(13), strSub)
Else
ErrorOption intErrorMode, Err.number, Err.Description
End If
Exit Sub
ErrorHandler:
'If FindObject fails when the user allows multiple selections
If Err.number = -2147352567 Then
HandleError intErrorMode
Resume NextObject
ElseIf Err.number = -2147200630 Then
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1195, Chr(13), strSub)
Resume NextObject
Else
HandleError (intErrorMode)
End If
End Sub
'***************************On Scan*******************************************************
'kei03062008 iFix4.7 Added bSendMsg option
Public Sub OnScan(Optional DataPoint As String, Optional intErrorMode As Integer = 0, Optional bSendMsg As Boolean = True)
Dim AppObj As Object
Dim DataPointObj As Object
Dim PictureObj As Object
Dim SelObj As Object
Dim strDataSource As String
Dim vtResults
Dim vtAttributeNames
Dim lStatus As Long
Dim strCurrentValueName As String
Dim strScanName As String
Dim ScanObj As Object
Dim iLength As Integer
'jrc
Dim strSub As String
'jrc 120199
Dim strOn As String
Dim strOff As String
Dim bPerformWrite As Boolean
If intErrorMode <> 1 Then
On Error GoTo ErrorHandler
End If
If DataPoint = "" Then
'If this routine is called from the background task, the user must enter a tag
Dim strDocType As String
GetActiveDocType strDocType
' activedoctype returns nothing if no pictures open or in background task
If strDocType = "Nothing" Then
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1059)
End If
Exit Sub
End If
Set PictureObj = Application.ActiveDocument.page
'If this routine is called from a schedule, the user must enter a tag
If PictureObj.ClassName = "Scheduler" Then
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1059)
End If
Exit Sub
End If
Set SelObj = PictureObj.SelectedShapes
If SelObj.Count = 0 Then
ErrorOption intErrorMode, ERR_NUM_NOOBJECTSELECTEDFORROUTINE, NLSStrMgr.GetNLSStr(1198)
Exit Sub
End If
For Each SelObj In PictureObj.SelectedShapes
strDataSource = FindDataSource(SelObj, "")
If strDataSource = "" Then
ErrorOption intErrorMode, ERR_NUM_NOCONNECTIONTODATASOURCE, NLSStrMgr.GetNLSStr(1170, SelObj.Name)
Exit Sub
End If
'jrc
PictureObj.TagGroupSubstitution strDataSource, strSub
Set DataPointObj = System.FindObject(strSub)
If TypeName(DataPointObj) = "Nothing" Then
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1171, SelObj.Name, Chr(13), strSub)
Exit Sub
End If
DataPointObj.GetPropertyAttributes DataPointObj.FullyQualifiedName, 0, vtResults, vtAttributeNames, lStatus
If lStatus <> 0 Then
GoTo StatusHandler
End If
strCurrentValueName = vtAttributeNames(0)
iLength = Len(strCurrentValueName) - 4
strScanName = Left(strCurrentValueName, iLength) & "A_SCAN"
strDataSource = strScanName
Set ScanObj = System.FindObject(strDataSource)
'jrc 120199
strOn = NLSStrMgr.GetNLSStr(1247)
strOff = NLSStrMgr.GetNLSStr(1248)
ShowESignatureDlg PictureObj, strDataSource, strOn, False, bPerformWrite, strOff, strOn, intErrorMode
If bPerformWrite = True Then
ScanObj.Value = strOn
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1061, ScanObj.FullyQualifiedName), ScanObj.FullyQualifiedName
End If
End If
NextObject:
Next
Else
'jlk031999 The FixBackgroundServer does not support ActiveDocument
GetActiveDocType strDocType
' activedoctype returns nothing if no pictures open or in background task
If strDocType <> "Nothing" Then
Set PictureObj = Application.ActiveDocument.page
'jrc
PictureObj.TagGroupSubstitution DataPoint, strSub
Else
strSub = DataPoint
End If
On Error GoTo FindObjectError
Set DataPointObj = System.FindObject(strSub)
DataPointObj.GetPropertyAttributes DataPointObj.FullyQualifiedName, 0, vtResults, vtAttributeNames, lStatus
If lStatus <> 0 Then
GoTo StatusHandler
End If
strCurrentValueName = vtAttributeNames(0)
iLength = Len(strCurrentValueName) - 4
strScanName = Left(strCurrentValueName, iLength) & "A_SCAN"
strDataSource = strScanName
Set ScanObj = System.FindObject(strDataSource)
'jrc 120199
strOn = NLSStrMgr.GetNLSStr(1247)
strOff = NLSStrMgr.GetNLSStr(1248)
ShowESignatureDlg PictureObj, strDataSource, strOn, False, bPerformWrite, strOff, strOn, intErrorMode
If bPerformWrite = True Then
ScanObj.Value = strOn
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1061, ScanObj.FullyQualifiedName), ScanObj.FullyQualifiedName
End If
End If
End If
Exit Sub
StatusHandler:
Select Case lStatus
Case 1
ErrorOption intErrorMode, ERR_NUM_DATASOURCEINVALIDSYNTAX, NLSStrMgr.GetNLSStr(1199, Chr(13), strSub)
Case 2
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1200, Chr(13), strSub)
Case 3
ErrorOption intErrorMode, ERR_NUM_DATASOURCEDATATYPEMISMATCH, NLSStrMgr.GetNLSStr(1201, Chr(13), strSub)
End Select
Exit Sub
'If FindObject fails when the user specifies just one datapoint
FindObjectError:
'data source is undefined
If Err.number = -2147200630 Then
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1200, Chr(13), strSub)
'Field Values are unknown
' ElseIf Err.number = -2147352567 Then
' ErrorOption intErrorMode, ERR_NUM_FIELDVALUESUNKNOWN, NLSStrMgr.GetNLSStr(1202, Chr(13), strSub)
Else
ErrorOption intErrorMode, Err.number, Err.Description
End If
Exit Sub
ErrorHandler:
'If FindObject fails when the user allows multiple selections
If Err.number = -2147352567 Then
HandleError intErrorMode
Resume NextObject
ElseIf Err.number = -2147200630 Then
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1200, Chr(13), strSub)
Resume NextObject
Else
HandleError (intErrorMode)
End If
End Sub
'******************************Off Scan********************************************
'kei03062008 iFix4.7 Added bSendMsg option
Public Sub OffScan(Optional DataPoint As String, Optional intErrorMode As Integer = 0, Optional bSendMsg As Boolean = True)
Dim AppObj As Object
Dim DataPointObj As Object
Dim PictureObj As Object
Dim SelObj As Object
Dim strDataSource As String
Dim vtResults
Dim vtAttributeNames
Dim lStatus As Long
Dim strCurrentValueName As String
Dim strScanName As String
Dim ScanObj As Object
Dim iLength As Integer
'jrc
Dim strSub As String
'jrc 120199
Dim strOff As String
Dim strOn As String
Dim bPerformWrite As Boolean
If intErrorMode <> 1 Then
On Error GoTo ErrorHandler
End If
If DataPoint = "" Then
'If this routine is called from the background task, the user must enter a tag.
Dim strDocType As String
GetActiveDocType strDocType
' activedoctype returns nothing if no pictures open or in background task
If strDocType = "Nothing" Then
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1065)
End If
Exit Sub
End If
Set PictureObj = Application.ActiveDocument.page
'If this routine is called from a schedule, the user must enter a tag.
If PictureObj.ClassName = "Scheduler" Then
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1065)
End If
Exit Sub
End If
Set SelObj = PictureObj.SelectedShapes
If SelObj.Count = 0 Then
ErrorOption intErrorMode, ERR_NUM_NOOBJECTSELECTEDFORROUTINE, NLSStrMgr.GetNLSStr(1203)
Exit Sub
End If
For Each SelObj In PictureObj.SelectedShapes
strDataSource = FindDataSource(SelObj, "")
If strDataSource = "" Then
ErrorOption intErrorMode, ERR_NUM_NOCONNECTIONTODATASOURCE, NLSStrMgr.GetNLSStr(1170, SelObj.Name)
Exit Sub
End If
'jrc
PictureObj.TagGroupSubstitution strDataSource, strSub
Set DataPointObj = System.FindObject(strSub)
If TypeName(DataPointObj) = "Nothing" Then
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1171, SelObj.Name, Chr(13), strSub)
Exit Sub
End If
DataPointObj.GetPropertyAttributes DataPointObj.FullyQualifiedName, 0, vtResults, vtAttributeNames, lStatus
If lStatus <> 0 Then
GoTo StatusHandler
End If
strCurrentValueName = vtAttributeNames(0)
iLength = Len(strCurrentValueName) - 4
strDataSource = Left(strCurrentValueName, iLength) & "A_SCAN"
On Error GoTo FindObjectError
Set ScanObj = System.FindObject(strDataSource)
'jrc 120199
strOn = NLSStrMgr.GetNLSStr(1247)
strOff = NLSStrMgr.GetNLSStr(1248)
ShowESignatureDlg PictureObj, strDataSource, strOff, False, bPerformWrite, strOff, strOn, intErrorMode
If bPerformWrite = True Then
ScanObj.Value = strOff
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1067, ScanObj.FullyQualifiedName), ScanObj.FullyQualifiedName
End If
End If
NextObject:
Next
Else
'jlk031999 The FixBackgroundServer does not support ActiveDocument
GetActiveDocType strDocType
' activedoctype returns nothing if no pictures open or in background task
If strDocType <> "Nothing" Then
Set PictureObj = Application.ActiveDocument.page
'jrc
PictureObj.TagGroupSubstitution DataPoint, strSub
Else
strSub = DataPoint
End If
On Error GoTo FindObjectError
Set DataPointObj = System.FindObject(strSub)
DataPointObj.GetPropertyAttributes DataPointObj.FullyQualifiedName, 0, vtResults, vtAttributeNames, lStatus
If lStatus <> 0 Then
GoTo StatusHandler
End If
strCurrentValueName = vtAttributeNames(0)
iLength = Len(strCurrentValueName) - 4
strDataSource = Left(strCurrentValueName, iLength) & "A_SCAN"
On Error GoTo FindObjectError
Set ScanObj = System.FindObject(strDataSource)
'jrc 120199
strOn = NLSStrMgr.GetNLSStr(1247)
strOff = NLSStrMgr.GetNLSStr(1248)
ShowESignatureDlg PictureObj, strDataSource, strOff, False, bPerformWrite, strOff, strOn, intErrorMode
If bPerformWrite = True Then
ScanObj.Value = strOff
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1067, ScanObj.FullyQualifiedName), ScanObj.FullyQualifiedName
End If
End If
End If
Exit Sub
StatusHandler:
Select Case lStatus
Case 1
ErrorOption intErrorMode, ERR_NUM_DATASOURCEINVALIDSYNTAX, NLSStrMgr.GetNLSStr(1204, Chr(13), strSub)
Case 2
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1205, Chr(13), strSub)
Case 3
ErrorOption intErrorMode, ERR_NUM_DATASOURCEDATATYPEMISMATCH, NLSStrMgr.GetNLSStr(1206, Chr(13), strSub)
End Select
Exit Sub
'If FindObject fails when the user specifies just one datapoint
FindObjectError:
'data source is undefined
If Err.number = -2147200630 Then
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1205, Chr(13), strSub)
'Field Values are unknown
' ElseIf Err.number = -2147352567 Then
' ErrorOption intErrorMode, ERR_NUM_FIELDVALUESUNKNOWN, NLSStrMgr.GetNLSStr(1207, Chr(13), strSub)
Else
ErrorOption intErrorMode, Err.number, Err.Description
End If
Exit Sub
ErrorHandler:
'If FindObject fails when the user allows multiple selections
If Err.number = -2147352567 Then
HandleError intErrorMode
Resume NextObject
ElseIf Err.number = -2147200630 Then
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1205, Chr(13), strSub)
Resume NextObject
Else
HandleError (intErrorMode)
End If
End Sub
'***************************Toggle Manual*********************************************
'kei03062008 iFix4.7 Added bSendMsg option
Public Sub ToggleManual(Optional DataPoint As String, Optional intErrorMode As Integer = 0, Optional bSendMsg As Boolean = True)
Dim AppObj As Object
Dim DataPointObj As Object
Dim PictureObj As Object
Dim SelObj As Object
Dim strDataSource As String
Dim vtResults
Dim vtAttributeNames
Dim lStatus As Long
Dim strCurrentValueName As String
Dim strModeName As String
Dim ModeObj As Object
Dim iLength As Integer
'jrc
Dim strSub As String
Dim bPerformWrite As Boolean
If intErrorMode <> 1 Then
On Error GoTo ErrorHandler
End If
If DataPoint = "" Then
'If this routine is called from the background task, the user must enter a datapoint.
Dim strDocType As String
GetActiveDocType strDocType
' activedoctype returns nothing if no pictures open or in background task
If strDocType = "Nothing" Then
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1071)
End If
Exit Sub
End If
Set PictureObj = Application.ActiveDocument.page
'If this routine is called from a schedule, the user must enter a datapoint.
If PictureObj.ClassName = "Scheduler" Then
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1071)
End If
Exit Sub
End If
Set SelObj = PictureObj.SelectedShapes
If SelObj.Count = 0 Then
ErrorOption intErrorMode, ERR_NUM_NOOBJECTSELECTEDFORROUTINE, NLSStrMgr.GetNLSStr(1208)
Exit Sub
End If
For Each SelObj In PictureObj.SelectedShapes
strDataSource = FindDataSource(SelObj, "")
If strDataSource = "" Then
ErrorOption intErrorMode, ERR_NUM_NOCONNECTIONTODATASOURCE, NLSStrMgr.GetNLSStr(1170, SelObj.Name)
Exit Sub
End If
'jrc
PictureObj.TagGroupSubstitution strDataSource, strSub
Set DataPointObj = System.FindObject(strSub)
If (TypeName(DataPointObj) = "Nothing") Then
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1171, SelObj.Name, Chr(13), strSub)
Exit Sub
End If
DataPointObj.GetPropertyAttributes DataPointObj.FullyQualifiedName, 0, vtResults, vtAttributeNames, lStatus
If lStatus <> 0 Then
GoTo StatusHandler
End If
strCurrentValueName = vtAttributeNames(0)
iLength = Len(strCurrentValueName) - 4
strDataSource = Left(strCurrentValueName, iLength) & "A_AUTO"
On Error GoTo FindObjectError
Set ModeObj = System.FindObject(strDataSource)
If ModeObj.Value = "PAUT" Then
ShowESignatureDlg PictureObj, strDataSource, "MANL", False, bPerformWrite, "MANL", "AUTO", intErrorMode
If bPerformWrite = True Then
ModeObj.Value = "MANL"
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1073, ModeObj.FullyQualifiedName), ModeObj.FullyQualifiedName
End If
End If
ElseIf ModeObj.Value = "PMAN" Then
ShowESignatureDlg PictureObj, strDataSource, "AUTO", False, bPerformWrite, "MANL", "AUTO", intErrorMode
If bPerformWrite = True Then
ModeObj.Value = "AUTO"
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1074, ModeObj.FullyQualifiedName), ModeObj.FullyQualifiedName
End If
End If
End If
If ModeObj.Value = "AUTO" Then
ShowESignatureDlg PictureObj, strDataSource, "MANL", False, bPerformWrite, "MANL", "AUTO", intErrorMode
If bPerformWrite = True Then
ModeObj.Value = "MANL"
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1073, ModeObj.FullyQualifiedName), ModeObj.FullyQualifiedName
End If
End If
ElseIf ModeObj.Value = "MANL" Then
ShowESignatureDlg PictureObj, strDataSource, "AUTO", False, bPerformWrite, "MANL", "AUTO", intErrorMode
If bPerformWrite = True Then
ModeObj.Value = "AUTO"
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1074, ModeObj.FullyQualifiedName), ModeObj.FullyQualifiedName
End If
End If
End If
NextObject:
Next
Else
'jlk031999 The FixBackgroundServer does not support ActiveDocument
GetActiveDocType strDocType
' activedoctype returns nothing if no pictures open or in background task
If strDocType <> "Nothing" Then
Set PictureObj = Application.ActiveDocument.page
'jrc
PictureObj.TagGroupSubstitution DataPoint, strSub
Else
strSub = DataPoint
End If
On Error GoTo FindObjectError
Set DataPointObj = System.FindObject(strSub)
DataPointObj.GetPropertyAttributes DataPointObj.FullyQualifiedName, 0, vtResults, vtAttributeNames, lStatus
If lStatus <> 0 Then
GoTo StatusHandler
End If
strCurrentValueName = vtAttributeNames(0)
iLength = Len(strCurrentValueName) - 4
'hj070903 Should not change the string value of passed-in parameter DataPoint.
'Instead, use local variable strDataSource to keep the new string.
strDataSource = Left(strCurrentValueName, iLength) & "A_AUTO"
Set ModeObj = System.FindObject(strDataSource)
If ModeObj.Value = "AUTO" Then
'hj070903
ShowESignatureDlg PictureObj, strDataSource, "MANL", False, bPerformWrite, "MANL", "AUTO", intErrorMode
If bPerformWrite = True Then
ModeObj.Value = "MANL"
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1073, ModeObj.FullyQualifiedName), ModeObj.FullyQualifiedName
End If
End If
Else
'hj070903
ShowESignatureDlg PictureObj, strDataSource, "AUTO", False, bPerformWrite, "MANL", "AUTO", intErrorMode
If bPerformWrite = True Then
ModeObj.Value = "AUTO"
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1074, ModeObj.FullyQualifiedName), ModeObj.FullyQualifiedName
End If
End If
End If
End If
Exit Sub
StatusHandler:
Select Case lStatus
Case 1
ErrorOption intErrorMode, ERR_NUM_DATASOURCEINVALIDSYNTAX, NLSStrMgr.GetNLSStr(1209, Chr(13), strSub)
Case 2
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1210, Chr(13), strSub)
Case 3
ErrorOption intErrorMode, ERR_NUM_DATASOURCEDATATYPEMISMATCH, NLSStrMgr.GetNLSStr(1211, Chr(13), strSub)
End Select
Exit Sub
'If FindObject fails when the user specifies just one datapoint
FindObjectError:
'data source is undefined
If Err.number = -2147200630 Then
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1210, Chr(13), strSub)
'Field Values are unknown
' ElseIf Err.number = -2147352567 Then
' ErrorOption intErrorMode, ERR_NUM_FIELDVALUESUNKNOWN, NLSStrMgr.GetNLSStr(1212, Chr(13), strSub)
Else
ErrorOption intErrorMode, Err.number, Err.Description
End If
Exit Sub
ErrorHandler:
'If FindObject fails when the user allows multiple selections
If Err.number = -2147352567 Then
HandleError intErrorMode
Resume NextObject
ElseIf Err.number = -2147200630 Then
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1210, Chr(13), strSub)
Resume NextObject
Else
HandleError (intErrorMode)
End If
End Sub
'***************************Set Manual************************************************
'kei03062008 iFix4.7 Added bSendMsg option
Public Sub SetManual(Optional DataPoint As String, Optional intErrorMode As Integer = 0, Optional bSendMsg As Boolean = True)
Dim AppObj As Object
Dim DataPointObj As Object
Dim PictureObj As Object
Dim SelObj As Object
Dim vtResults
Dim vtAttributeNames
Dim lStatus As Long
Dim strCurrentValueName As String
Dim strModeName As String
Dim ModeObj As Object
Dim iLength As Integer
Dim strDataSource As String
'jrc
Dim strSub As String
Dim bPerformWrite As Boolean
If intErrorMode <> 1 Then
On Error GoTo ErrorHandler
End If
If DataPoint = "" Then
'If this routine is called from the background task, the user must enter a tag.
Dim strDocType As String
GetActiveDocType strDocType
' activedoctype returns nothing if no pictures open or in background task
If strDocType = "Nothing" Then
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1078)
End If
Exit Sub
End If
Set PictureObj = Application.ActiveDocument.page
'If this routine is called from a schedule, the user must enter a tag.
If PictureObj.ClassName = "Scheduler" Then
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1078)
End If
Exit Sub
End If
Set SelObj = PictureObj.SelectedShapes
If SelObj.Count = 0 Then
ErrorOption intErrorMode, ERR_NUM_NOOBJECTSELECTEDFORROUTINE, NLSStrMgr.GetNLSStr(1213)
Exit Sub
End If
For Each SelObj In PictureObj.SelectedShapes
strDataSource = FindDataSource(SelObj, "")
If strDataSource = "" Then
ErrorOption intErrorMode, ERR_NUM_NOCONNECTIONTODATASOURCE, NLSStrMgr.GetNLSStr(1170, SelObj.Name)
Exit Sub
End If
'jrc
PictureObj.TagGroupSubstitution strDataSource, strSub
Set DataPointObj = System.FindObject(strSub)
If (DataPointObj = Empty) And (TypeName(DataPointObj) = "Nothing") Then
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1171, SelObj.Name, Chr(13), strSub)
Exit Sub
End If
DataPointObj.GetPropertyAttributes DataPointObj.FullyQualifiedName, 0, vtResults, vtAttributeNames, lStatus
If lStatus <> 0 Then
GoTo StatusHandler
End If
strCurrentValueName = vtAttributeNames(0)
iLength = Len(strCurrentValueName) - 4
strDataSource = Left(strCurrentValueName, iLength) & "A_AUTO"
Set ModeObj = System.FindObject(strDataSource)
ShowESignatureDlg PictureObj, strDataSource, "MANL", False, bPerformWrite, "MANL", "AUTO", intErrorMode
If bPerformWrite = True Then
ModeObj.Value = "MANL"
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1073, ModeObj.FullyQualifiedName), ModeObj.FullyQualifiedName
End If
End If
NextObject:
Next
Else
'jlk031999 The FixBackgroundServer does not support ActiveDocument
GetActiveDocType strDocType
' activedoctype returns nothing if no pictures open or in background task
If strDocType <> "Nothing" Then
Set PictureObj = Application.ActiveDocument.page
'jrc
PictureObj.TagGroupSubstitution DataPoint, strSub
Else
strSub = DataPoint
End If
On Error GoTo FindObjectError
Set DataPointObj = System.FindObject(strSub)
If lStatus <> 0 Then
GoTo StatusHandler
End If
DataPointObj.GetPropertyAttributes DataPointObj.FullyQualifiedName, 0, vtResults, vtAttributeNames, lStatus
strCurrentValueName = vtAttributeNames(0)
iLength = Len(strCurrentValueName) - 4
'hj070903 Should not change the string value of passed-in parameter DataPoint.
'Instead, use local variable strDataSource to keep the new string.
strDataSource = Left(strCurrentValueName, iLength) & "A_AUTO"
Set ModeObj = System.FindObject(strDataSource)
ShowESignatureDlg PictureObj, strDataSource, "MANL", False, bPerformWrite, "MANL", "AUTO", intErrorMode
If bPerformWrite = True Then
ModeObj.Value = "MANL"
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1073, ModeObj.FullyQualifiedName), ModeObj.FullyQualifiedName
End If
End If
End If
Exit Sub
StatusHandler:
Select Case lStatus
Case 1
ErrorOption intErrorMode, ERR_NUM_DATASOURCEINVALIDSYNTAX, NLSStrMgr.GetNLSStr(1214, Chr(13), strSub)
Case 2
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1215, Chr(13), strSub)
Case 3
ErrorOption intErrorMode, ERR_NUM_DATASOURCEDATATYPEMISMATCH, NLSStrMgr.GetNLSStr(1216, Chr(13), strSub)
End Select
Exit Sub
'If FindObject fails when the user specifies just one datapoint
FindObjectError:
'data source is undefined
If Err.number = -2147200630 Then
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1215, Chr(13), strSub)
'Field Values are unknown
' ElseIf Err.number = -2147352567 Then
' ErrorOption intErrorMode, ERR_NUM_FIELDVALUESUNKNOWN, NLSStrMgr.GetNLSStr(1217, Chr(13), strSub)
Else
ErrorOption intErrorMode, Err.number, Err.Description
End If
Exit Sub
ErrorHandler:
'If FindObject fails when the user allows multiple selections
If Err.number = -2147352567 Then
HandleError intErrorMode
Resume NextObject
ElseIf Err.number = -2147200630 Then
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1215, Chr(13), strSub)
Resume NextObject
Else
HandleError (intErrorMode)
End If
End Sub
'*******************************Set Auto**************************************************
'kei03062008 iFix4.7 Added bSendMsg option
Public Sub SetAuto(Optional DataPoint As String, Optional intErrorMode As Integer = 0, Optional bSendMsg As Boolean = True)
Dim AppObj As Object
Dim DataPointObj As Object
Dim SelObj As Object
Dim PictureObj As Object
Dim strDataSource As String
Dim vtResults
Dim vtAttributeNames
Dim lStatus As Long
Dim strCurrentValueName As String
Dim strModeName As String
Dim ModeObj As Object
Dim iLength As Integer
'jrc
Dim strSub As String
Dim bPerformWrite As Boolean
If intErrorMode <> 1 Then
On Error GoTo ErrorHandler
End If
If DataPoint = "" Then
'If this routine is called from the background task, the user must enter a tag
Dim strDocType As String
GetActiveDocType strDocType
' activedoctype returns nothing if no pictures open or in background task
If strDocType = "Nothing" Then
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1083)
End If
Exit Sub
End If
Set PictureObj = Application.ActiveDocument.page
'If this routine is called from a schedule, the user must enter a tag.
If PictureObj.ClassName = "Scheduler" Then
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1083)
End If
Exit Sub
End If
Set SelObj = PictureObj.SelectedShapes
If SelObj.Count = 0 Then
ErrorOption intErrorMode, ERR_NUM_NOOBJECTSELECTEDFORROUTINE, NLSStrMgr.GetNLSStr(1218)
Exit Sub
End If
For Each SelObj In PictureObj.SelectedShapes
strDataSource = FindDataSource(SelObj, "")
If strDataSource = "" Then
ErrorOption intErrorMode, ERR_NUM_NOCONNECTIONTODATASOURCE, NLSStrMgr.GetNLSStr(1170, SelObj.Name)
Exit Sub
End If
'jrc
PictureObj.TagGroupSubstitution strDataSource, strSub
Set DataPointObj = System.FindObject(strSub)
If (DataPointObj = Empty) And (TypeName(DataPointObj) = "Nothing") Then
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1171, SelObj.Name, Chr(13), strSub)
Exit Sub
End If
DataPointObj.GetPropertyAttributes DataPointObj.FullyQualifiedName, 0, vtResults, vtAttributeNames, lStatus
If lStatus <> 0 Then
GoTo StatusHandler
End If
strCurrentValueName = vtAttributeNames(0)
iLength = Len(strCurrentValueName) - 4
strDataSource = Left(strCurrentValueName, iLength) & "A_AUTO"
Set ModeObj = System.FindObject(strDataSource)
ShowESignatureDlg PictureObj, strDataSource, "AUTO", False, bPerformWrite, "MANL", "AUTO", intErrorMode
If bPerformWrite = True Then
ModeObj.Value = "AUTO"
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1074, ModeObj.FullyQualifiedName), ModeObj.FullyQualifiedName
End If
End If
NextObject:
Next
Else
'jlk031999 The FixBackgroundServer does not support ActiveDocument
GetActiveDocType strDocType
' activedoctype returns nothing if no pictures open or in background task
If strDocType <> "Nothing" Then
Set PictureObj = Application.ActiveDocument.page
'jrc
PictureObj.TagGroupSubstitution DataPoint, strSub
Else
strSub = DataPoint
End If
On Error GoTo FindObjectError
Set DataPointObj = System.FindObject(strSub)
DataPointObj.GetPropertyAttributes DataPointObj.FullyQualifiedName, 0, vtResults, vtAttributeNames, lStatus
If lStatus <> 0 Then
GoTo StatusHandler
End If
strCurrentValueName = vtAttributeNames(0)
iLength = Len(strCurrentValueName) - 4
'hj070903 Should not change the string value of passed-in parameter DataPoint.
'Instead, use local variable strDataSource to keep the new string.
strDataSource = Left(strCurrentValueName, iLength) & "A_AUTO"
Set ModeObj = System.FindObject(strDataSource)
ShowESignatureDlg PictureObj, strDataSource, "AUTO", False, bPerformWrite, "MANL", "AUTO", intErrorMode
If bPerformWrite = True Then
ModeObj.Value = "AUTO"
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1074, ModeObj.FullyQualifiedName), ModeObj.FullyQualifiedName
End If
End If
End If
Exit Sub
StatusHandler:
Select Case lStatus
Case 1
ErrorOption intErrorMode, ERR_NUM_DATASOURCEINVALIDSYNTAX, NLSStrMgr.GetNLSStr(1219, Chr(13), strSub)
Case 2
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1220, Chr(13), strSub)
Case 3
ErrorOption intErrorMode, ERR_NUM_DATASOURCEDATATYPEMISMATCH, NLSStrMgr.GetNLSStr(1221, Chr(13), strSub)
End Select
Exit Sub
'If FindObject fails when the user specifies just one datapoint
FindObjectError:
'data source is undefined
If Err.number = -2147200630 Then
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1220, Chr(13), strSub)
'Field Values are unknown
' ElseIf Err.number = -2147352567 Then
' ErrorOption intErrorMode, ERR_NUM_FIELDVALUESUNKNOWN, NLSStrMgr.GetNLSStr(1222, Chr(13), strSub)
Else
ErrorOption intErrorMode, Err.number, Err.Description
End If
Exit Sub
ErrorHandler:
'If FindObject fails when the user allows multiple selections
If Err.number = -2147352567 Then
HandleError intErrorMode
Resume NextObject
ElseIf Err.number = -2147200630 Then
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1220, Chr(13), strSub)
Resume NextObject
Else
HandleError (intErrorMode)
End If
End Sub
'*****************************Write Value**********************************************
'kei03062008 iFix4.7 Added bSendMsg option
Public Sub WriteValue(Value As String, Optional DataPoint As String, Optional intErrorMode As Integer = 0, Optional bSendMsg As Boolean = True)
Dim AppObj As Object
Dim SelObj As Object
Dim DataPointObj As Object
Dim PictureObj As Object
Dim strDataSource As String
'jrc
Dim strSub As String
Dim bPerformWrite As Boolean
If intErrorMode <> 1 Then
On Error GoTo ErrorHandler
End If
If DataPoint = "" Then
'If this routine is called from the background task, the user must enter a datapoint
Dim strDocType As String
GetActiveDocType strDocType
' activedoctype returns nothing if no pictures open or in background task
If strDocType = "Nothing" Then
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1088)
End If
Exit Sub
End If
Set PictureObj = Application.ActiveDocument.page
'If this routine is called from a schedule, the user must enter a datapoint
If PictureObj.ClassName = "Scheduler" Then
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1088)
End If
Exit Sub
End If
Set SelObj = PictureObj.SelectedShapes
If SelObj.Count = 0 Then
ErrorOption intErrorMode, ERR_NUM_NOOBJECTSELECTEDFORROUTINE, NLSStrMgr.GetNLSStr(1223)
Exit Sub
End If
For Each SelObj In PictureObj.SelectedShapes
strDataSource = FindDataSource(SelObj, "")
If strDataSource = "" Then
ErrorOption intErrorMode, ERR_NUM_NOCONNECTIONTODATASOURCE, NLSStrMgr.GetNLSStr(1170, SelObj.Name)
Exit Sub
End If
'jrc
PictureObj.TagGroupSubstitution strDataSource, strSub
Set DataPointObj = System.FindObject(strSub)
If (TypeName(DataPointObj) = "Nothing") Then
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1171, SelObj.Name, Chr(13), strSub)
Exit Sub
End If
'lad 042202 Tracker #3507 use fully qualified name
ShowESignatureDlg PictureObj, DataPointObj.FullyQualifiedName, Value, False, bPerformWrite, "", "", intErrorMode
If bPerformWrite = True Then
DataPointObj.Value = Value
If bSendMsg = True Then
'MDK032603
If InStr(strSub, "%") Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1055, Value, DataPointObj.FullyQualifiedName), DataPointObj.FullyQualifiedName
Else
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1055, DataPointObj.FullyQualifiedName, Value), DataPointObj.FullyQualifiedName
End If
End If
End If
NextObject:
Next
Else
'jlk031999 The FixBackgroundServer does not support ActiveDocument
GetActiveDocType strDocType
' activedoctype returns nothing if no pictures open or in background task
If strDocType <> "Nothing" Then
Set PictureObj = Application.ActiveDocument.page
'jrc
PictureObj.TagGroupSubstitution DataPoint, strSub
Else
strSub = DataPoint
End If
On Error GoTo FindObjectError
'Set up Picture object if call to subroutine is from a picture
Set DataPointObj = System.FindObject(strSub)
'lad 042202 Tracker #3507 use fully qualified name
ShowESignatureDlg PictureObj, DataPointObj.FullyQualifiedName, Value, False, bPerformWrite, "", "", intErrorMode
If bPerformWrite = True Then
DataPointObj.Value = Value
If bSendMsg = True Then
'MDK032603
If InStr(strSub, "%") Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1055, Value, DataPointObj.FullyQualifiedName), DataPointObj.FullyQualifiedName
Else
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1055, DataPointObj.FullyQualifiedName, Value), DataPointObj.FullyQualifiedName
End If
End If
End If
End If
Exit Sub
'If FindObject fails when the user specifies just one datapoint
FindObjectError:
'data source is undefined
If Err.number = -2147200630 Then
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1224, Chr(13), strSub)
'Field Values are unknown
' ElseIf Err.number = -2147352567 Then
' ErrorOption intErrorMode, ERR_NUM_FIELDVALUESUNKNOWN, NLSStrMgr.GetNLSStr(1225, Chr(13), strSub)
'jtt06232005 T642
ElseIf Err.number = -2147199452 Then
ErrorOption intErrorMode, Err.number, NLSStrMgr.GetNLSStr(1252, Chr(13), "")
Else
ErrorOption intErrorMode, Err.number, Err.Description
End If
Exit Sub
ErrorHandler:
'If FindObject fails when the user allows multiple selections
If Err.number = -2147352567 Then
HandleError intErrorMode
Resume NextObject
ElseIf Err.number = -2147200630 Then
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1224, Chr(13), strSub)
Resume NextObject
Else
HandleError (intErrorMode)
End If
End Sub
'******************************Read Value*********************************************
'kei03062008 iFix4.7 Did not add bSendMsg option since it sends an error message only
'Public Function ReadValue(Optional DataPoint As String, Optional intErrorMode As Integer = 0, Optional bSendMsg As Boolean = True)
Public Function ReadValue(Optional DataPoint As String, Optional intErrorMode As Integer = 0)
Dim AppObj As Object
Dim SelObj As Object
Dim DataPointObj As Object
Dim PictureObj As Object
Dim strDataSource As String
'jrc
Dim strSub As String
If intErrorMode <> 1 Then
On Error GoTo ErrorHandler
End If
If DataPoint = "" Then
'If this routine is called from the background task, the user must enter a tag.
Dim strDocType As String
GetActiveDocType strDocType
' activedoctype returns nothing if no pictures open or in background task
If strDocType = "Nothing" Then
'If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1090)
'End If
Exit Function
End If
Set PictureObj = Application.ActiveDocument.page
'If this routine is called from a schedule, the user must enter a tag.
If PictureObj.ClassName = "Scheduler" Then
'If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1090)
'End If
Exit Function
End If
Set SelObj = PictureObj.SelectedShapes
If SelObj.Count = 0 Then
ErrorOption intErrorMode, ERR_NUM_NOOBJECTSELECTEDFORROUTINE, NLSStrMgr.GetNLSStr(1226)
Exit Function
End If
For Each SelObj In PictureObj.SelectedShapes
strDataSource = FindDataSource(SelObj, "")
If strDataSource = "" Then
ErrorOption intErrorMode, ERR_NUM_NOCONNECTIONTODATASOURCE, NLSStrMgr.GetNLSStr(1170, SelObj.Name)
Exit Function
End If
'jrc
PictureObj.TagGroupSubstitution strDataSource, strSub
Set DataPointObj = System.FindObject(strSub)
If (TypeName(DataPointObj) = "Nothing") Then
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1171, SelObj.Name, Chr(13), strSub)
Exit Function
End If
ReadValue = DataPointObj.Value
'System.SendOperatorMessage DataPointObj.FullyQualifiedName & " set to " & ReadValue, DataPointObj.FullyQualifiedName
NextObject:
Next
Else
'jlk031999 The FixBackgroundServer does not support ActiveDocument
GetActiveDocType strDocType
' activedoctype returns nothing if no pictures open or in background task
If strDocType <> "Nothing" Then
Set PictureObj = Application.ActiveDocument.page
'jrc
PictureObj.TagGroupSubstitution DataPoint, strSub
Else
strSub = DataPoint
End If
On Error GoTo FindObjectError
Set DataPointObj = System.FindObject(strSub)
'If Err.number = -2147200630 Then
'ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, "Read Value" + Chr(13) + "Data source is undefined: " + strSub
'ElseIf Err.number <> 0 Then
'ErrorOption intErrorMode, Err.number, Err.Description, Err.Source
'ErrorOption intErrorMode, ERR_NUM_FIELDVALUESUNKNOWN, "Read Value" + Chr(13) + "Field's value not known: " + strSub
'End If
'Give a Field Values unknown error
ReadValue = DataPointObj.Value
'If Err.number <> 0 Then
'ErrorOption intErrorMode, ERR_NUM_FIELDVALUESUNKNOWN, "Read Value" + Chr(13) + "Field's value not known: " + strSub
'End If
'System.SendOperatorMessage DataPointObj.FullyQualifiedName & " set to " & ReadValue, DataPointObj.FullyQualifiedName
End If
Exit Function
'If FindObject fails when the user specifies just one datapoint
FindObjectError:
'data source is undefined
If Err.number = -2147200630 Then
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1227, Chr(13), strSub)
'Field Values are unknown
ElseIf Err.number = -2147352567 Then
ErrorOption intErrorMode, ERR_NUM_FIELDVALUESUNKNOWN, NLSStrMgr.GetNLSStr(1228, Chr(13), strSub)
Else
ErrorOption intErrorMode, Err.number, Err.Description
End If
Exit Function
ErrorHandler:
'If FindObject fails when the user allows multiple selections
If Err.number = -2147352567 Then
HandleError intErrorMode
Resume NextObject
ElseIf Err.number = -2147200630 Then
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1227, Chr(13), strSub)
Resume NextObject
Else
HandleError (intErrorMode)
End If
End Function
'******************************Toggle Scan**********************************************
'kei03062008 iFix4.7 Added bSendMsg option
Public Sub ToggleScan(Optional DataPoint As String, Optional intErrorMode As Integer = 0, Optional bSendMsg As Boolean = True)
Dim AppObj As Object
Dim DataPointObj As Object
Dim PictureObj As Object
Dim SelObj As Object
Dim strDataSource As String
Dim vtResults
Dim vtAttributeNames
Dim lStatus As Long
Dim strCurrentValueName As String
Dim strScanName As String
Dim ScanObj As Object
Dim iLength As Integer
Dim lDisp As Long
'jrc
Dim strSub As String
'jrc 120199
Dim strOn As String
Dim strOff As String
Dim bPerformWrite As Boolean
If intErrorMode <> 1 Then
On Error GoTo ErrorHandler
End If
If DataPoint = "" Then
'If this routine is called from the background task, the user must enter a data point
Dim strDocType As String
GetActiveDocType strDocType
' activedoctype returns nothing if no pictures open or in background task
If strDocType = "Nothing" Then
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1092)
End If
Exit Sub
End If
Set PictureObj = Application.ActiveDocument.page
'If this routine is called from a schedule, the user must enter a data point
If PictureObj.ClassName = "Scheduler" Then
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1092)
End If
Exit Sub
End If
Set SelObj = PictureObj.SelectedShapes
If SelObj.Count = 0 Then
ErrorOption intErrorMode, ERR_NUM_NOOBJECTSELECTEDFORROUTINE, NLSStrMgr.GetNLSStr(1229)
Exit Sub
End If
For Each SelObj In PictureObj.SelectedShapes
strDataSource = FindDataSource(SelObj, "")
If strDataSource = "" Then
ErrorOption intErrorMode, ERR_NUM_NOCONNECTIONTODATASOURCE, NLSStrMgr.GetNLSStr(1170, SelObj.Name)
Exit Sub
End If
'jrc
PictureObj.TagGroupSubstitution strDataSource, strSub
Set DataPointObj = System.FindObject(strSub)
If TypeName(DataPointObj) = "Nothing" Then
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1171, SelObj.Name, Chr(13), strSub)
Exit Sub
End If
DataPointObj.GetPropertyAttributes DataPointObj.FullyQualifiedName, 0, vtResults, vtAttributeNames, lStatus
If lStatus <> 0 Then
GoTo StatusHandler
End If
strCurrentValueName = vtAttributeNames(0)
iLength = Len(strCurrentValueName) - 4
strDataSource = Left(strCurrentValueName, iLength) & "A_SCAN"
On Error GoTo FindObjectError
Set ScanObj = System.FindObject(strDataSource)
strOn = NLSStrMgr.GetNLSStr(1247)
strOff = NLSStrMgr.GetNLSStr(1248)
If LTrim(RTrim(ScanObj.Value)) = strOff Then
ShowESignatureDlg PictureObj, strDataSource, strOn, False, bPerformWrite, strOff, strOn, intErrorMode
If bPerformWrite = True Then
ScanObj.Value = strOn
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1061, ScanObj.FullyQualifiedName), ScanObj.FullyQualifiedName
End If
End If
ElseIf LTrim(RTrim(ScanObj.Value)) = strOn Then
ShowESignatureDlg PictureObj, strDataSource, strOff, False, bPerformWrite, strOff, strOn, intErrorMode
If bPerformWrite = True Then
ScanObj.Value = strOff
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1067, ScanObj.FullyQualifiedName), ScanObj.FullyQualifiedName
End If
End If
End If
NextObject:
Next
Else
'jlk031999 The FixBackgroundServer does not support ActiveDocument
GetActiveDocType strDocType
' activedoctype returns nothing if no pictures open or in background task
If strDocType <> "Nothing" Then
Set PictureObj = Application.ActiveDocument.page
'jrc
PictureObj.TagGroupSubstitution DataPoint, strSub
Else
strSub = DataPoint
End If
On Error GoTo FindObjectError
Set DataPointObj = System.FindObject(strSub)
DataPointObj.GetPropertyAttributes DataPointObj.FullyQualifiedName, 0, vtResults, vtAttributeNames, lStatus
If lStatus <> 0 Then
GoTo StatusHandler
End If
strCurrentValueName = vtAttributeNames(0)
iLength = Len(strCurrentValueName) - 4
strDataSource = Left(strCurrentValueName, iLength) & "A_SCAN"
Set ScanObj = System.FindObject(strDataSource)
strOn = NLSStrMgr.GetNLSStr(1247)
strOff = NLSStrMgr.GetNLSStr(1248)
If LTrim(RTrim(ScanObj.Value)) = strOff Then
ShowESignatureDlg PictureObj, strDataSource, strOn, False, bPerformWrite, strOff, strOn, intErrorMode
If bPerformWrite = True Then
ScanObj.Value = strOn
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1061, ScanObj.FullyQualifiedName), ScanObj.FullyQualifiedName
End If
End If
ElseIf LTrim(RTrim(ScanObj.Value)) = strOn Then
ShowESignatureDlg PictureObj, strDataSource, strOff, False, bPerformWrite, strOff, strOn, intErrorMode
If bPerformWrite = True Then
ScanObj.Value = strOff
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1067, ScanObj.FullyQualifiedName), ScanObj.FullyQualifiedName
End If
End If
End If
End If
Exit Sub
StatusHandler:
Select Case lStatus
Case 1
ErrorOption intErrorMode, ERR_NUM_DATASOURCEINVALIDSYNTAX, NLSStrMgr.GetNLSStr(1230, Chr(13), strSub)
Case 2
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1231, Chr(13), strSub)
Case 3
ErrorOption intErrorMode, ERR_NUM_DATASOURCEDATATYPEMISMATCH, NLSStrMgr.GetNLSStr(1232, Chr(13), strSub)
End Select
Exit Sub
'If FindObject fails when the user specifies just one datapoint
FindObjectError:
'data source is undefined
If Err.number = -2147200630 Then
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1231, Chr(13), strSub)
'Field Values are unknown
' ElseIf Err.number = -2147352567 Then
' ErrorOption intErrorMode, ERR_NUM_FIELDVALUESUNKNOWN, NLSStrMgr.GetNLSStr(1233, Chr(13), strSub)
Else
ErrorOption intErrorMode, Err.number, Err.Description
End If
Exit Sub
ErrorHandler:
'If FindObject fails when the user allows multiple selections
If Err.number = -2147352567 Then
HandleError intErrorMode
Resume NextObject
ElseIf Err.number = -2147200630 Then
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1231, Chr(13), strSub)
Resume NextObject
Else
HandleError (intErrorMode)
End If
End Sub
'*********************************Disable Alarm*****************************************
'kei03062008 iFix4.7 Added bSendMsg option
Public Sub DisableAlarm(Optional DataPoint As String, Optional intErrorMode As Integer = 0, Optional bSendMsg As Boolean = True)
Dim AppObj As Object
Dim DataPointObj As Object
Dim PictureObj As Object
Dim SelObj As Object
Dim strDataSource As String
Dim strPropertyName As String
Dim vtResults
Dim vtAttributeNames
Dim lStatus As Long
Dim strCurrentValueName As String
Dim strScanName As String
Dim ScanObj As Object
Dim iLength As Integer
'jrc
Dim strSub As String
'jrc 120199
Dim strNO As String
Dim strYES As String
Dim bPerformWrite As Boolean
If intErrorMode <> 1 Then
On Error GoTo ErrorHandler
End If
'If the user did not enter a DataPoint, set DataPoint equal to the name of the data source for the
'currently selected item.
If DataPoint = "" Then
'If this routine is called from the background task, the user must enter a tag
Dim strDocType As String
GetActiveDocType strDocType
' activedoctype returns nothing if no pictures open or in background task
If strDocType = "Nothing" Then
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1097)
End If
Exit Sub
End If
Set PictureObj = Application.ActiveDocument.page
'If this routine is called from a schedule, the user must enter a tag
If PictureObj.ClassName = "Scheduler" Then
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1097)
End If
Exit Sub
End If
Set SelObj = PictureObj.SelectedShapes
If SelObj.Count = 0 Then
ErrorOption intErrorMode, ERR_NUM_NOOBJECTSELECTEDFORROUTINE, NLSStrMgr.GetNLSStr(1234)
End
End If
For Each SelObj In PictureObj.SelectedShapes
strDataSource = FindDataSource(SelObj, "")
If strDataSource = "" Then
ErrorOption intErrorMode, ERR_NUM_NOCONNECTIONTODATASOURCE, NLSStrMgr.GetNLSStr(1170, SelObj.Name)
Exit Sub
End If
'jrc
PictureObj.TagGroupSubstitution strDataSource, strSub
Set DataPointObj = System.FindObject(strSub)
If (TypeName(DataPointObj) = "Nothing") Then
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1171, SelObj.Name, Chr(13), strSub)
Exit Sub
End If
strPropertyName = DataPointObj.FullyQualifiedName
DataPointObj.GetPropertyAttributes DataPointObj.FullyQualifiedName, 0, vtResults, vtAttributeNames, lStatus
If lStatus <> 0 Then
GoTo StatusHandler
End If
strCurrentValueName = vtAttributeNames(0)
iLength = Len(strCurrentValueName) - 4
strDataSource = Left(strCurrentValueName, iLength) & "A_ENAB"
Set ScanObj = System.FindObject(strDataSource)
'jrc 120199
strYES = NLSStrMgr.GetNLSStr(1249)
strNO = NLSStrMgr.GetNLSStr(1250)
ShowESignatureDlg PictureObj, strDataSource, strNO, False, bPerformWrite, strNO, strYES, intErrorMode
If bPerformWrite = True Then
ScanObj.Value = strNO
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1100, ScanObj.FullyQualifiedName), ScanObj.FullyQualifiedName
End If
End If
NextObject:
Next
Exit Sub
'If the user selected a specific datapoint.
Else
'jlk031999 The FixBackgroundServer does not support ActiveDocument
GetActiveDocType strDocType
' activedoctype returns nothing if no pictures open or in background task
If strDocType <> "Nothing" Then
Set PictureObj = Application.ActiveDocument.page
'jrc
PictureObj.TagGroupSubstitution DataPoint, strSub
Else
strSub = DataPoint
End If
On Error GoTo FindObjectError
Set DataPointObj = System.FindObject(strSub)
DataPointObj.GetPropertyAttributes DataPointObj.FullyQualifiedName, 0, vtResults, vtAttributeNames, lStatus
If lStatus <> 0 Then
GoTo StatusHandler
End If
strCurrentValueName = vtAttributeNames(0)
iLength = Len(strCurrentValueName) - 4
strDataSource = Left(strCurrentValueName, iLength) & "A_ENAB"
Set ScanObj = System.FindObject(strDataSource)
'jrc 120199
strYES = NLSStrMgr.GetNLSStr(1249)
strNO = NLSStrMgr.GetNLSStr(1250)
ShowESignatureDlg PictureObj, strDataSource, strNO, False, bPerformWrite, strNO, strYES, intErrorMode
If bPerformWrite = True Then
ScanObj.Value = strNO
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1100, ScanObj.FullyQualifiedName), ScanObj.FullyQualifiedName
End If
End If
End If
Exit Sub
StatusHandler:
Select Case lStatus
Case 1
ErrorOption intErrorMode, ERR_NUM_DATASOURCEINVALIDSYNTAX, NLSStrMgr.GetNLSStr(1235, Chr(13), strSub)
Case 2
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1236, Chr(13), strSub)
Case 3
ErrorOption intErrorMode, ERR_NUM_DATASOURCEDATATYPEMISMATCH, NLSStrMgr.GetNLSStr(1237, Chr(13), strSub)
End Select
Exit Sub
'If FindObject fails when the user specifies just one datapoint
FindObjectError:
'data source is undefined
If Err.number = -2147200630 Then
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1236, Chr(13), strSub)
'Field Values are unknown
' ElseIf Err.number = -2147352567 Then
' ErrorOption intErrorMode, ERR_NUM_FIELDVALUESUNKNOWN, NLSStrMgr.GetNLSStr(1238, Chr(13), strSub)
Else
ErrorOption intErrorMode, Err.number, Err.Description
End If
Exit Sub
ErrorHandler:
'If FindObject fails when the user allows multiple selections
If Err.number = -2147352567 Then
HandleError intErrorMode
Resume NextObject
ElseIf Err.number = -2147200630 Then
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1236, Chr(13), strSub)
Resume NextObject
Else
HandleError (intErrorMode)
End If
End Sub
'***********************Enable Alarm****************************************************
'kei03062008 iFix4.7 Added bSendMsg option
Public Sub EnableAlarm(Optional DataPoint As String, Optional intErrorMode As Integer = 0, Optional bSendMsg As Boolean = True)
Dim AppObj As Object
Dim DataPointObj As Object
Dim PictureObj As Object
Dim SelObj As Object
Dim strDataSource As String
Dim strPropertyName As String
Dim vtResults
Dim vtAttributeNames
Dim lStatus As Long
Dim strCurrentValueName As String
Dim strScanName As String
Dim ScanObj As Object
Dim iLength As Integer
'jrc
Dim strSub As String
'jrc 120199
Dim strYES As String
Dim strNO As String
Dim bPerformWrite As Boolean
If intErrorMode <> 1 Then
On Error GoTo ErrorHandler
End If
'If the user did not enter a DataPoint, set DataPoint equal to the name of the data source for the
'currently selected item.
If DataPoint = "" Then
'If this routine is called from the background task, the user must enter a tag
Dim strDocType As String
GetActiveDocType strDocType
' activedoctype returns nothing if no pictures open or in background task
If strDocType = "Nothing" Then
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1104)
End If
Exit Sub
End If
Set PictureObj = Application.ActiveDocument.page
'If this routine is called from a schedule, the user must enter a tag
If PictureObj.ClassName = "Scheduler" Then
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1104)
End If
Exit Sub
End If
Set SelObj = PictureObj.SelectedShapes
If SelObj.Count = 0 Then
ErrorOption intErrorMode, ERR_NUM_NOOBJECTSELECTEDFORROUTINE, NLSStrMgr.GetNLSStr(1239)
End
End If
For Each SelObj In PictureObj.SelectedShapes
strDataSource = FindDataSource(SelObj, "")
If strDataSource = "" Then
ErrorOption intErrorMode, ERR_NUM_NOCONNECTIONTODATASOURCE, NLSStrMgr.GetNLSStr(1170, SelObj.Name)
Exit Sub
End If
'jrc
PictureObj.TagGroupSubstitution strDataSource, strSub
Set DataPointObj = System.FindObject(strSub)
If (TypeName(DataPointObj) = "Nothing") Then
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1171, SelObj.Name, Chr(13), strSub)
Exit Sub
End If
strPropertyName = DataPointObj.FullyQualifiedName
DataPointObj.GetPropertyAttributes DataPointObj.FullyQualifiedName, 0, vtResults, vtAttributeNames, lStatus
If lStatus <> 0 Then
GoTo StatusHandler
End If
strCurrentValueName = vtAttributeNames(0)
iLength = Len(strCurrentValueName) - 4
strDataSource = Left(strCurrentValueName, iLength) & "A_ENAB"
On Error GoTo FindObjectError
Set ScanObj = System.FindObject(strDataSource)
'jrc 120199
strYES = NLSStrMgr.GetNLSStr(1249)
strNO = NLSStrMgr.GetNLSStr(1250)
ShowESignatureDlg PictureObj, strDataSource, strYES, False, bPerformWrite, strNO, strYES, intErrorMode
If bPerformWrite = True Then
ScanObj.Value = strYES
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1107, ScanObj.FullyQualifiedName), ScanObj.FullyQualifiedName
End If
End If
NextObject:
Next
Exit Sub
'If the user selected a specific datapoint.
Else
'jlk031999 The FixBackgroundServer does not support ActiveDocument
GetActiveDocType strDocType
' activedoctype returns nothing if no pictures open or in background task
If strDocType <> "Nothing" Then
Set PictureObj = Application.ActiveDocument.page
'jrc
PictureObj.TagGroupSubstitution DataPoint, strSub
Else
strSub = DataPoint
End If
On Error GoTo FindObjectError
Set DataPointObj = System.FindObject(strSub)
DataPointObj.GetPropertyAttributes DataPointObj.FullyQualifiedName, 0, vtResults, vtAttributeNames, lStatus
If lStatus <> 0 Then
GoTo StatusHandler
End If
strCurrentValueName = vtAttributeNames(0)
iLength = Len(strCurrentValueName) - 4
strDataSource = Left(strCurrentValueName, iLength) & "A_ENAB"
On Error GoTo FindObjectError
Set ScanObj = System.FindObject(strDataSource)
'jrc 120199
strYES = NLSStrMgr.GetNLSStr(1249)
strNO = NLSStrMgr.GetNLSStr(1250)
ShowESignatureDlg PictureObj, strDataSource, strYES, False, bPerformWrite, strNO, strYES, intErrorMode
If bPerformWrite = True Then
ScanObj.Value = strYES
If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1107, ScanObj.FullyQualifiedName), ScanObj.FullyQualifiedName
End If
End If
End If
Exit Sub
StatusHandler:
Select Case lStatus
Case 1
ErrorOption intErrorMode, ERR_NUM_DATASOURCEINVALIDSYNTAX, NLSStrMgr.GetNLSStr(1240, Chr(13), strSub)
Case 2
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1241, Chr(13), strSub)
Case 3
ErrorOption intErrorMode, ERR_NUM_DATASOURCEDATATYPEMISMATCH, NLSStrMgr.GetNLSStr(1242, Chr(13), strSub)
End Select
Exit Sub
'If FindObject fails when the user specifies just one datapoint
FindObjectError:
'data source is undefined
If Err.number = -2147200630 Then
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1241, Chr(13), strSub)
'Field Values are unknown
' ElseIf Err.number = -2147352567 Then
' ErrorOption intErrorMode, ERR_NUM_FIELDVALUESUNKNOWN, NLSStrMgr.GetNLSStr(1243, Chr(13), strSub)
Else
ErrorOption intErrorMode, Err.number, Err.Description
End If
Exit Sub
ErrorHandler:
'If FindObject fails when the user allows multiple selections
If Err.number = -2147352567 Then
HandleError intErrorMode
Resume NextObject
ElseIf Err.number = -2147200630 Then
ErrorOption intErrorMode, ERR_NUM_UNDEFINEDDATASOURCE, NLSStrMgr.GetNLSStr(1241, Chr(13), strSub)
Resume NextObject
Else
HandleError (intErrorMode)
End If
End Sub
'*****************************Locate Object********************************************
Public Sub LocateObject(ObjectName As String, Optional bRelative As Boolean, Optional intErrorMode As Integer = 0)
Dim AppObj As Object
Dim DocumentObjs As Object
Dim DocObj As Object
Dim CurrentObj As Object
'jrc
Dim strSub As String
If intErrorMode <> 1 Then
On Error GoTo ErrorHandler
End If
' Is this script running in the workspace or background
If TypeName(Application) = "CFixApp" Then
' running in the workspace
Set AppObj = Application
Else
' running in the background
' see if we can get the workspace object
Set AppObj = App
If AppObj Is Nothing Then
Exit Sub
End If
End If
If bRelative Then
Set DocumentObjs = AppObj.ActiveDocument.page
'jrc
DocumentObjs.TagGroupSubstitution ObjectName, strSub
'turn off error handling
On Error Resume Next
Set CurrentObj = DocumentObjs.FindObject(strSub)
If TypeName(CurrentObj) <> "Nothing" Then
CurrentObj.IsSelectable = True
CurrentObj.Select
End If
'turn on appropriate error handling
If intErrorMode <> 1 Then
On Error GoTo ErrorHandler
Else
On Error GoTo 0
End If
Else
Set DocumentObjs = AppObj.Documents
For Each DocObj In DocumentObjs
If DocObj.Name = "User" Then
GoTo NextDocument
End If
'jrc
DocObj.page.TagGroupSubstitution ObjectName, strSub
'turn off error handling
On Error Resume Next
Set CurrentObj = DocObj.page.FindObject(strSub)
If TypeName(CurrentObj) = "Nothing" Then
GoTo NextDocument
End If
'turn on appropriate error handling
If intErrorMode <> 1 Then
On Error GoTo ErrorHandler
Else
On Error GoTo 0
End If
AppObj.ActiveDocument.active = False
DocObj.active = True
CurrentObj.IsSelectable = True
CurrentObj.Select
NextDocument:
Next
End If
Exit Sub
ErrorHandler:
If InStr(1, Err.Description, NLSStrMgr.GetNLSStr(1244), vbTextCompare) Then
Set CurrentObj = Nothing
Resume Next
Else
HandleError (intErrorMode)
End If
End Sub
'**********************************Picture Alias****************************************
'hj030609 Added an optional param to specify which picture should get the alias
'Public Sub PictureAlias(PictureAlias As String, Optional intErrorMode As Integer = 0)
Public Sub PictureAlias(PictureAlias As String, Optional intErrorMode As Integer = 0, Optional PictureObj As Object = Nothing)
Dim AppObj As Object
Dim PictureDoc As Object
If intErrorMode <> 1 Then
On Error GoTo ErrorHandler
End If
' Is this script running in the workspace or background
If TypeName(Application) = "CFixApp" Then
' running in the workspace
Set AppObj = Application
Else
' running in the background
' see if we can get the workspace object
Set AppObj = App
If AppObj Is Nothing Then
Exit Sub
End If
End If
'hj030609
'If a picture is passed in, the specified picture will get the alias
If TypeName(PictureObj) = "CFixPicture" Then
Set PictureDoc = PictureObj.Parent
Else 'otherwise the current active picture will get the alias
Set PictureDoc = AppObj.ActiveDocument
End If
PictureDoc.ActiveWindow.WindowName = PictureAlias
Exit Sub
ErrorHandler:
HandleError (intErrorMode)
End Sub
'*******************Log In*****************************************
Public Sub LogIn(Optional intErrorMode As Integer = 0, Optional bPushCurrentUser As Boolean = False)
Dim strPath As String
Dim strCmdParam As String
If intErrorMode <> 1 Then
On Error GoTo ErrorHandler
End If
strPath = System.BasePath
strPath = strPath & "\login.exe "
strCmdParam = "-m"
If (bPushCurrentUser = True) Then
strCmdParam = strCmdParam & "-p"
End If
Shell strPath & strCmdParam, 1
Exit Sub
ErrorHandler:
HandleError (intErrorMode)
End Sub
'********************Handle Error**********************************
Public Sub HandleError(Optional intErrorMode As Integer = 0)
Dim strErrorString As String
If DisableErrorHandling = True Then
Exit Sub
End If
strErrorString = NLSStrMgr.GetNLSStr(1111, Err.number, Hex(Err.number), Chr(13), Chr(13), Err.Description)
' If Err.number = 1000006 Then
' Exit Sub
' End If
If intErrorMode = 1 Then
' we should never get here because this routine should only be called
' in the error handler. Furthermore, if we raise an error while
' in an error handler, it will cause the script to END ungracefully.
' Option one is used to throw back (raise) errors to the calling function.
MsgBox Err.Description, vbOKOnly Or vbCritical
Err.Raise Err.number, Err.Source, Err.Description
ElseIf intErrorMode = 2 Then
System.SendOperatorMessage strErrorString
Else '= 0
MsgBox strErrorString
End If
End Sub
'*************************Acknowledge All Alarms*********************************
'kei03062008 iFix4.7 Did not add bSendMsg option since AlarmSummary automatically send operator message
'Public Sub AcknowledgeAllAlarms(Optional Picture As String, Optional intErrorMode As Integer = 0, Optional bSendMsg As Boolean = True)
Public Sub AcknowledgeAllAlarms(Optional Picture As String, Optional intErrorMode As Integer = 0)
Dim AppObj As Object
Dim PictureObj As Object
Dim SelObj As Object
Dim vtResults
Dim vtAlarmObjNames
Dim lStatus As Long
Dim intAlias As Integer
If intErrorMode <> 1 Then
On Error GoTo ErrorHandler
End If
' Is this script running in the workspace or background
If TypeName(Application) = "CFixApp" Then
' running in the workspace
Set AppObj = Application
Else
' running in the background
' see if we can get the workspace object
Set AppObj = App
If AppObj Is Nothing Then
Exit Sub
End If
End If
Picture = UCase(Picture)
'If user enters nothing for Picture meaning: acknowledge all alarms for the current
'picture in run mode then:
If Picture = "" Then
Set PictureObj = AppObj.ActiveDocument
Picture = PictureObj.page.Name
GoTo AcknowledgeAlarm
End If
'If the user entered a picture file name, check to see if the full path is supplied by checking for a "\" in the string.
If InStr(1, Picture, "\", vbTextCompare) <> 0 Then
'If it is supplied, check to see if the file's extension is supplied.
If InStr(1, Picture, ".", vbTextCompare) = 0 Then
'add .grf onto the file name.
Picture = Picture & ".grf"
'If the file extension is supplied, make sure it is ".grf". If it is not, go to the NoSuchPicture message.
ElseIf InStr(1, Picture, "grf", vbTextCompare) = 0 Then
GoTo NoSuchPicture
End If
'Check to see if this file actually exists.
If Dir(Picture) = "" Then
GoTo NoSuchPicture
End If
For Each PictureObj In AppObj.Documents
If TypeName(PictureObj.ActiveWindow) <> "Nothing" Then
If InStr(1, Picture, PictureObj.FileName, vbTextCompare) <> 0 Then
GoTo AcknowledgeAlarm
End If
End If
Next
Exit Sub
'If there is no "\" in the Picture string, the user did not specify the full path. Chck to see if the user supplied an extension.
Else
If InStr(1, Picture, ".", vbTextCompare) = 0 Then
'The entry may be an alias
intAlias = 0
For Each PictureObj In AppObj.Documents
If TypeName(PictureObj.ActiveWindow) <> "Nothing" Then
If UCase(PictureObj.ActiveWindow.WindowName) = UCase(Picture) Then
GoTo AcknowledgeAlarm
intAlias = intAlias + 1
End If
End If
Next
If intAlias > 0 Then
Exit Sub
End If
'add on .grf
Picture = Picture & ".grf"
ElseIf InStr(1, Picture, "grf", vbTextCompare) = 0 Then
GoTo NoSuchPicture
Exit Sub
End If
'Add the Fix Pic path to the file name
Picture = System.picturepath & "\" & Picture
If Dir(Picture) = "" Then
GoTo NoSuchPicture
End If
For Each PictureObj In AppObj.Documents
If TypeName(PictureObj.ActiveWindow) <> "Nothing" Then
If InStr(1, Picture, PictureObj.FileName, vbTextCompare) <> 0 Then
GoTo AcknowledgeAlarm
End If
End If
Next
End If
AcknowledgeAlarm:
'This section of the subroutine uses the DataSystem ocx to create a group from
'all items with new alarms. It then uses the DataSystem ocx to do a group read and
'group write. It also handles any alarmsummary ocx's that have new alarms.
Dim FDS As Object
Dim PictureObjs As Object
Dim CurrentObj As Object
Dim SourceName As String
Dim Source As Object
Dim AlarmSource As Object
Dim vtAckAlarmNames
Dim lngStatus As Long
Dim DIItem As Object
'lad 040902 Tracker #2195 - make this Public so AckAllAlarmSummary can set it
'Dim bAlarmSummaryFlag As Boolean
Dim strAckAlarmName As String
Dim strYES As String
Dim strNO As String
'lad 040802 Tracker #2195
Dim bAlarmAcked As Boolean
bAlarmAcked = False
bAlarmSummaryFlag = False
' Is this script running in the workspace or background
If TypeName(Application) = "CFixApp" Then
' running in the workspace
Set AppObj = Application
Else
' running in the background
' see if we can get the workspace object
Set AppObj = App
If AppObj Is Nothing Then
Exit Sub
End If
End If
'The next 8 lines check to see if there is an AlarmSummary control in the picture.
'If there is, use the AlarmSummary AckAllAlarms method to acknowledge all alarms.
'blm102600 - First make sure we have a valid Picture Object
If PictureObj Is Nothing Then
Exit Sub
End If
For Each CurrentObj In PictureObj.page.ContainedObjects
Call AckAllAlarmSummary(CurrentObj)
Next
Set FDS = CreateObject("FixDataSystems.Intellution FD Data System Control")
FDS.Groups.Add "AlarmGrp"
'If the picture is not open, give the user a message.
If TypeName(PictureObj) = "Nothing" Then
ErrorOption intErrorMode, ERR_NUM_PICNOTOPEN, NLSStrMgr.GetNLSStr(1112, Picture)
Exit Sub
End If
'Now, we will step through all the objects in the picture and check to
'see if they are connected to a data item. If they are, we will add them
'to a collection and then read the entire collection and write a NO to all
'items in the collection with a group write.
Call GetAllAlarmConnections(PictureObj.page)
Dim k As Integer
For k = 1 To AllConnectionsCollection.Count
'PBH 05/29/2003 - T1873 - SIM Integration BEGIN
'hj040703 Need to handle TAGGROUP symbols in the collection
'FDS.Groups.Item(1).DataItems.Add AllConnectionsCollection.Item(k)
Dim strSub As String
strAckAlarmName = AllConnectionsCollection.Item(k)
PictureObj.page.TagGroupSubstitution strAckAlarmName, strSub
'If this item is a tag group symbol, need to find out the data source
'and then the acknowledge alarm name of the source.
If StrComp(strAckAlarmName, strSub, vbTextCompare) <> 0 Then
Set Source = System.FindObject(strSub)
strAckAlarmName = GetFieldString(Source.FullyQualifiedName, "A_NALM")
End If
FDS.Groups.Item(1).DataItems.Add strAckAlarmName
'PBH 05/29/2003 - T1873 - SIM Integration END
Next
strYES = NLSStrMgr.GetNLSStr(1249)
strNO = NLSStrMgr.GetNLSStr(1250)
'Read all of the data items
FDS.Groups.Item(1).Read
For Each DIItem In FDS.Groups.Item(1).DataItems
'If the user selected a Use Anyway on any of the links, the .Value property will fail. We need to handle this scenario.
On Error GoTo UseAnyway
If InStr(1, UCase(DIItem.Value), strYES, vbTextCompare) <> 0 Then
DIItem.Value = strNO
'lad 040802 flag that we acked an alarm and need to send the message
bAlarmAcked = True
End If
UseAnyway:
Resume Next
Next
FDS.Groups.Item(1).Write
'If we didn't use Alarm Summary's AckAllAlarms method, then we need to send an operator message.
'lad 040802 Tracker #2195 - but only send the message if we actually acknowledged alarms
If bAlarmSummaryFlag = False Then
If bAlarmAcked = True Then
'If bSendMsg = True Then
System.SendOperatorMessage NLSStrMgr.GetNLSStr(1113)
'End If
' silence alarm horn whenever an alarm is acked
' alarm summary should silence it, but this code executes when no almsum is present.
System.SilenceAlarmHorn
End If
End If
Exit Sub
NoSuchPicture:
ErrorOption intErrorMode, ERR_NUM_PICNOTFOUND, NLSStrMgr.GetNLSStr(1024, Picture)
Exit Sub
ErrorHandler:
If Err.number = -2147200630 Then
Resume Next
Else
HandleError (intErrorMode)
End If
End Sub
Private Sub AckAllAlarmSummary(Obj As Object)
Dim ContObj As Object
'lad 040902 Tracker #2195 - make this Public so AcknowledgeAllAlarms can use it
'Dim bAlarmSummaryFlag As Boolean
Dim objContContained As Object
Dim i As Integer
Dim j As Integer
If Obj Is Nothing Then
Exit Sub
End If
If TypeName(Obj) = "AlarmSummaryOCX" Then
On Error Resume Next
'lad 040902 Tracker #2195 - only call this if the alarm summary object has
'acknowledge all alarms enabled
If Obj.EnableAcknowledgeAll = True Then
Obj.AckAllAlarms
bAlarmSummaryFlag = True
End If
End If
If Obj.ContainedObjects.Count > 0 Then
For j = 1 To Obj.ContainedObjects.Count
Set ContObj = Obj.ContainedObjects.Item(j)
Call AckAllAlarmSummary(ContObj)
Next
End If
End Sub
Private Function GetFieldString(strSourceFQN As String, strFieldID) As String
Dim i
Dim Pos
Dim strSearchChar As String
strSearchChar = "."
i = 1
Do
Pos = InStr(i + 1, strSourceFQN, strSearchChar, 1)
If Pos = 0 Then
Exit Do
Else
i = Pos
End If
Loop
GetFieldString = Left(strSourceFQN, i) & strFieldID
End Function
'*********************Get All Connections*******************************************
Public Sub GetAllConnections(Obj As Object)
Dim intAllCollectionsCount As Integer
'Clear the AllConnectionsCollection collection
For intAllCollectionsCount = 1 To AllConnectionsCollection.Count
AllConnectionsCollection.Remove 1
Next
Call lGetAllConnections(Obj)
End Sub
Private Sub lGetAllConnections(Obj As Object)
Dim j As Integer
Dim lConnectedCount As Long
Dim iNumProperties As Integer
Dim strProp As String
Dim strSource As String
Dim strFullyQualifiedSource As String
Dim vtsourceobjects As Variant
Dim SourceObj As Object
Dim k As Integer
Dim ObjectContained As Object
Dim strObjName As String
'For the object passed into the subroutine, get a list of all of its connections
Obj.ConnectedPropertyCount lConnectedCount
iNumProperties = CInt(lConnectedCount)
'If there are connections to the object, get the connection information
If iNumProperties <> 0 Then
For j = 1 To iNumProperties
Obj.GetConnectionInformation j, strProp, strSource, strFullyQualifiedSource, vtsourceobjects
'If the object is a FixGlobalSysInfo object, it does not support the ClassName
'property so skip it.
If TypeName(vtsourceobjects(0)) <> "FixGlobalSysInfo" Then
'If the object is connected to an OPCDataItem object, add the OPCDataItem object
'to the collection.
'MDK102405 T2594 ported Siebel hj072205 195001621 but used a select statement instead
'If UCase(vtsourceobjects(0).ClassName) = "COPCDATAITEM" Then
Select Case UCase(vtsourceobjects(0).ClassName)
Case "COPCDATAITEM"
AllConnectionsCollection.Add vtsourceobjects(0).FullyQualifiedName
Case "TAGGROUP"
AllConnectionsCollection.Add vtsourceobjects(0).FullyQualifiedName
End Select
'End If
End If
Next
End If
If Obj.ContainedObjects.Count > 0 Then
For k = 1 To Obj.ContainedObjects.Count
Set ObjectContained = Obj.ContainedObjects.Item(k)
Call lGetAllConnections(ObjectContained)
Next
End If
End Sub
Private Sub GetAllAlarmConnections(PictureObj As Object)
Dim intCollectionCount As Integer
Dim ContObj As Object
Dim i As Integer
'Clear the AllConnectionsCollection collection
For intCollectionCount = 1 To AllConnectionsCollection.Count
AllConnectionsCollection.Remove 1
Next
For i = 1 To PictureObj.ContainedObjects.Count
Set ContObj = PictureObj.ContainedObjects.Item(i)
Call lGetAllAlarmConnections(ContObj)
Next
End Sub
Private Sub lGetAllAlarmConnections(Obj As Object)
Dim j As Integer
Dim lConnectedCount As Long
Dim iNumProperties As Integer
Dim strProp As String
Dim strSource As String
Dim strFullyQualifiedSource As String
Dim vtsourceobjects As Variant
Dim SourceObj As Object
Dim strAckAlarmName As String
'lad 032602 Tracker #3029 port jes 112701 243809
Dim i As Integer 'jes112701
Dim iNumvtsourceobjects As Integer 'jes112701
Obj.ConnectedPropertyCount lConnectedCount
iNumProperties = CInt(lConnectedCount)
'If there are connections to the object, get them
If iNumProperties <> 0 Then
For j = 1 To iNumProperties
Obj.GetConnectionInformation j, strProp, strSource, strFullyQualifiedSource, vtsourceobjects
'If the object is a FixGlobalSysInfo object, it does not support the ClassName
'lad 032602 Tracker #3029 port jes 112701 243809
'jes112701 to handle complex datasources
If Not (IsEmpty(vtsourceobjects)) Then 'mr092704 C1-25827301 if the datasource for the animation
'is a constant (i.e. "1") the vtsourceobjects are empty and
'we get a Type mismatch on UBound of the empty object.
iNumvtsourceobjects = CInt(UBound(vtsourceobjects))
For i = 0 To iNumvtsourceobjects
' end jes112701
'If the object is a FixGlobalSysInfo object, it does not support the ClassName
'property so skip it.
'
'jes112701 iterate through all sources
'If TypeName(vtsourceobjects(0)) <> "FixGlobalSysInfo" Then
If TypeName(vtsourceobjects(i)) <> "FixGlobalSysInfo" Then
'If the object is connected to an OPCDataItem object, add the OPCDataItem object
'to the collection.
'
'jes112701 iterate through all sources
'If UCase(vtsourceobjects(0).ClassName) = "COPCDATAITEM" Then
' strAckAlarmName = GetFieldString(vtsourceobjects(0).FullyQualifiedName, "A_NALM")
If UCase(vtsourceobjects(i).ClassName) = "COPCDATAITEM" Then
'ab03122003 T1187 Port jes020403 don't acknowledge non-iFix OPCDatasources
If Not InStr(1, strFullyQualifiedSource, "Fix32", 1) = 0 Then
strAckAlarmName = GetFieldString(vtsourceobjects(i).FullyQualifiedName, "A_NALM")
AllConnectionsCollection.Add strAckAlarmName
End If
'PBH 05/29/2003 - T1873 - SIM Integration BEGIN
'hj040703 If this is a TAGGROUP symbol, put it in the collection as well.
ElseIf UCase(vtsourceobjects(i).ClassName) = "TAGGROUP" Then
AllConnectionsCollection.Add vtsourceobjects(i).FullyQualifiedName
'PBH 05/29/2003 - T1873 - SIM Integration END
End If
End If
Next 'jes112701
End If 'mr092704 C1-25827301
Next
End If
'Check if the object that was connected to the previous object has any contained objects.
'If it does, recurse through this subroutine.
Dim k As Integer
Dim ObjectContained As Object
Dim strObjName As String
If Obj.ContainedObjects.Count > 0 Then
For k = 1 To Obj.ContainedObjects.Count
Set ObjectContained = Obj.ContainedObjects.Item(k)
Call lGetAllAlarmConnections(ObjectContained)
Next
End If
End Sub
'************************Is User FXG*************************************************
Public Function IsUserFxg() As Boolean
Dim AppObj As Object
Dim lngCount As Long
Dim strName As String
' Is this script running in the workspace or background
If TypeName(Application) = "CFixApp" Then
' running in the workspace
Set AppObj = Application
Else
' running in the background
' see if we can get the workspace object
Set AppObj = App
If AppObj Is Nothing Then
Exit Function
End If
End If
IsUserFxg = False
lngCount = AppObj.Documents.Count
If lngCount = 1 Then
strName = AppObj.Documents(1).Name
If StrComp(strName, "User", 1) = 0 Then
IsUserFxg = True
End If
End If
End Function
'***********************App********************************************************
Private Function App() As Object
' expect errors if wksp not running... just ignore
On Error Resume Next
' if workspace is not running, this will return "Nothing"
Set App = GetObject(, "Workspace.Application")
Err.Clear ' Clear Err object in case error occurred.
End Function
Public Sub PrintReport(ByVal Report As String, Optional Prompt As Boolean, Optional ByVal Copies As Long, Optional ByVal Coll As Boolean, Optional ByVal StartNo As Long, Optional ByVal EndNo As Long, Optional intErrorMode As Integer = 0)
Dim CrystalReport As Object
Dim lngResult As Long
Dim lngRes As Long
Dim intEngine As Integer
'lad 10/19/2005 T1855
Dim sKey As String ' Key to open
Dim hKey As Long ' Handle to registry key
Dim bCrystalReports11 As Boolean
If intErrorMode <> 1 Then
On Error GoTo ErrorHandler
End If
'lad 10/19/2005 T1855 - check for version 11 runtime files
sKey = "SOFTWARE\Business Objects\suite 11.0\Crystal Reports"
lngResult = RegOpenKeyEx(&H80000002, sKey, 0, &H20000, hKey)
RegCloseKey (&H80000002)
'lad 04/2602007 T3876 - if not found check for version 11.5 runtime files
If lngResult <> 0 Then
sKey = "SOFTWARE\Business Objects\suite 11.5\Crystal Reports"
lngResult = RegOpenKeyEx(&H80000002, sKey, 0, &H20000, hKey)
RegCloseKey (&H80000002)
End If
If lngResult = 0 Then
If TypeName(CrystalApplication) = "Nothing" Then
Set CrystalApplication = CreateObject("CrystalRuntime.Application")
End If
bCrystalReports11 = True
Else
'lad 10/19/2005 T1855 - didn't find version 11 so check for earlier version
lngResult = RegOpenKeyEx(&H80000000, "CrystalReports", &O0, &H20000, lngRes)
If Not lngResult = 0 Then 'check for runtime installation
lngResult = RegOpenKeyEx(&H80000000, "CrystalDataObject.CrystalComObject", &O0, &H20000, lngRes)
RegCloseKey (&H80000000)
End If
If lngResult = 0 Then
If TypeName(CrystalApplication) = "Nothing" Then
Set CrystalApplication = CreateObject("Crystal.CRPE.Application")
End If
Else
ErrorOption intErrorMode, ERR_NUM_CRYSTALREPORTSNOTINSTALLED, NLSStrMgr.GetNLSStr(1114)
End
End If
End If
Set CrystalReport = CrystalApplication.OpenReport(Report)
If bCrystalReports11 = False Then
intEngine = PEOpenEngine
CrystalReport.PrintOut Prompt, Copies, Coll, StartNo, EndNo
Set CrystalReport = Nothing
PECloseEngine
Else
Set PrintReportXI = New frmPrintReportXI
PrintReportXI.SetReportSource CrystalReport
PrintReportXI.ViewReport
PrintReportXI.Show
Unload PrintReportXI
End If
Exit Sub
ErrorHandler:
If Err.number = 429 Then
ErrorOption intErrorMode, ERR_NUM_CRYSTALREPORTSVERSIONERROR, NLSStrMgr.GetNLSStr(1245)
Else
HandleError (intErrorMode)
End If
End Sub
'***************************Quick Add***********************************************
Public Function QuickAdd(ByVal DataSource As String, Optional intErrorMode As Integer = 0) As Integer
Dim lStatus As Long
Dim ValidObjects
Dim UndefinedObjects
Dim strFullyQualifiedSource As String
Dim bCanConstruct As Boolean
Dim undefined As String
Dim Result
Dim iQuickAddValue As Integer
If intErrorMode <> 1 Then
On Error GoTo ErrorHandler
End If
System.ParseConnectionSource "Name", DataSource, lStatus, ValidObjects, UndefinedObjects, strFullyQualifiedSource
Select Case lStatus
Case 0
QuickAdd = 0
Case 1
'MsgBox "Invalid Syntax for Data Source."
QuickAdd = 1
Case 2
Dim i As Integer
Dim szundefinedmsg As String
Dim query
Dim vtpos
Dim strsection As String
Dim objSection As Object
Dim msg As String
iQuickAddValue = 2
szundefinedmsg = ""
For i = 0 To (UBound(UndefinedObjects))
'Set the variable undefined equal to the string name of the undefined object. If the
'user entered a new data source, the undefined object will be what they entered in The
'ExpressionEditor.
undefined = UndefinedObjects(i)
If IsTagGroupSyntax(undefined) = False Then
If IsUndefinedObjectSyntax(undefined) = True Then
msg = NLSStrMgr.GetNLSStr(1116, undefined)
Result = MsgBox(msg, vbYesNo)
'If the user chooses to "Use Anyway" for the data source they enter, return
'a value of 4 which indicates Use Anyway. Otherwise, return a value of 5 which
'means the user did not choose to use the data source they entered.
If Result = vbYes Then
iQuickAddValue = 4
Else
QuickAdd = 5
Exit Function
End If
Else
'Check if the user defined a section name - the Defaut Data System, a picture, a schedule...
vtpos = InStr(1, undefined, ".", vbTextCompare)
If vtpos <> 0 Then
strsection = Left(undefined, vtpos - 1)
On Error Resume Next
Set objSection = System.FindObject(strsection)
End If
'If no section is defined:
If (Err.number <> 0) Or (vtpos = 0) Or (UCase(strsection) = UCase(System.DefaultDataSystem)) Then
'Add the Default Data System as the section if it is not already included.
If InStr(1, undefined, System.DefaultDataSystem, vbTextCompare) = 0 Then
undefined = System.DefaultDataSystem & "." & undefined
End If
'Make sure we can create this new block.
System.CanConstruct undefined, bCanConstruct
'If it is possible to create the block, make sure that is what the user wants to do.
If bCanConstruct Then
msg = NLSStrMgr.GetNLSStr(1117, undefined)
Result = MsgBox(msg, vbYesNo)
'If the user does want to add a new database block, use the Construct method to
'launch the QuickAdd dialog box.
If Result = vbYes Then
System.Construct undefined, lStatus
'If the add is unsuccessful, return the value for the QuickAdd subroutine
'that indicates invalid syntax. Otherwise, return the value 2 which indicates
'that the user added a block.
If lStatus = 1 Then
QuickAdd = 1
Exit Function
End If
Else
'If the user chooses not to add the database block at this time, let them
'choose to use the database block without defining it.
msg = NLSStrMgr.GetNLSStr(1118, undefined)
Result = MsgBox(msg, vbYesNo)
'If the user chooses to "Use Anyway" for the data source they enter, return
'a value of 4 which indicates Use Anyway. Otherwise, return a value of 5 which
'means the user did not choose to use the data source they entered.
If Result = vbYes Then
iQuickAddValue = 4
Else
QuickAdd = 5
Exit Function
End If
End If
End If
'If a section is defined but it is not the Data system, let the user choose to use it anyway.
Else
If objSection.Name <> System.DefaultDataSystem Then
'lad 07052005 T1449 port hj100504
'hj100504 Should not allow the user to choose to use it anyway if the section is not
'the Data System, as only the data system allows late bound objects. Using it anyway
'without its being late bindable will later end up with error "Cannot late bind object.
'Check for invalid name." at call SetSource().
'msg = NLSStrMgr.GetNLSStr(1119, undefined)
'Result = MsgBox(msg, vbYesNo)
''If the user chooses to "Use Anyway" for the data source they enter, return
''a value of 4 which indicates Use Anyway. Otherwise, return a value of 5 which
''means the user did not choose to use the data source they entered.
'If Result = vbYes Then
' iQuickAddValue = 4
'Else
' QuickAdd = 5
' Exit Function
'End If
MsgBox (NLSStrMgr.GetNLSStr(6008, undefined))
QuickAdd = 5
Exit Function
End If
End If
End If 'Is UndefinedObject syntax
Else 'Is TagGroup syntax
iQuickAddValue = 0
End If
Next
QuickAdd = iQuickAddValue
Case 3
'MsgBox "Data Source contains a Data Type mismatch."
QuickAdd = 3
End Select
Exit Function
DoNotCreate:
Exit Function
ErrorHandler:
HandleError (intErrorMode)
End Function
'*****************************Fetch Limits*************************************************
Public Sub FetchLimits(DataSource As String, HiLimit As Variant, LoLimit As Variant, ret As Integer, Optional intErrorMode As Integer = 0)
Dim lStatus As Long
Dim ValidObjects
Dim UndefinedObjects
Dim szFullyQualifiedSource As String
Dim SourceObj As Object
Dim SourceObject As Object
Dim szSourcePropertyName As String
Dim vtAttributeNames
Dim vtResults
Dim Result
Dim i As Integer
Dim vtLow
Dim vtHigh
ret = 0
On Error GoTo ErrorHandler
' Initialize the values to something reasonable
LoLimit = 0
HiLimit = 100
'begin jes Taggroup support -- PBH 5/16/2001 (Integrated SIM)
If InStr(1, DataSource, "@") Then
Dim strSub As String
Dim PictureObj As Object
Set PictureObj = Application.ActiveDocument.page
PictureObj.TagGroupSubstitution DataSource, strSub
DataSource = strSub
End If
'end jes
'This subroutine accepts a data source and returns its High and Low limits.
'Parse the DataSource to retrieve array of objects that are identified as part of the
'Data Source and are currently valid and used in the system. We are only concerned with
'Valid object that are a part of the data source, not undefined objects.
System.ParseConnectionSource "Name", DataSource, lStatus, ValidObjects, UndefinedObjects, szFullyQualifiedSource
'lStatus is 0 if connection is valid.
If lStatus = 0 Then
'Check if user entered @ for substitution
If InStr(1, DataSource, "@", 1) Then
Exit Sub
End If
'If the ParseConnectionSource was successful, make sure the data source is valid
System.ValidateSource ValidObjects(0).FullyQualifiedName, lStatus, SourceObject, szSourcePropertyName
If UCase(SourceObject.ClassName) = "COPCDATAITEM" Then
'Get the Low EGU data item object from vtAttributeNames
System.GetPropertyAttributes SourceObject.FullyQualifiedName, 2, vtResults, vtAttributeNames, lStatus
'If vtResults comes back as empty, use the EGULimits (enum 9). This is put in specifically
'for P31.
If lStatus = 0 Then
If TypeName(vtResults(0)) = "Empty" Then
System.GetPropertyAttributes SourceObject.FullyQualifiedName, 9, vtResults, vtAttributeNames, lStatus
If TypeName(vtResults(0)) <> "Empty" Then
Result = vtResults(0)
If (TypeName(Result(0)) <> "String") Or IsNumeric(Result(0)) Then
LoLimit = Result(0)
Else
LoLimit = 0
End If
If (TypeName(Result(1)) <> "String") Or IsNumeric(Result(1)) Then
HiLimit = Result(1)
Else
HiLimit = 100
End If
Else
LoLimit = 0
HiLimit = 100
lStatus = 0
End If
Else
If (TypeName(vtResults(0)) <> "String") Or IsNumeric(vtResults(0)) Then
LoLimit = vtResults(0)
Else
LoLimit = 0
End If
If (TypeName(vtResults(1)) <> "String") Or IsNumeric(vtResults(1)) Then
HiLimit = vtResults(1)
Else
HiLimit = 100
End If
End If
Else
System.GetPropertyAttributes SourceObject.FullyQualifiedName, 2, vtResults, vtAttributeNames, lStatus
'If no results are returned, return default values of 0 and 100
If TypeName(vtResults) = "Empty" Then
LoLimit = 0
HiLimit = 100
lStatus = 0
Else
LoLimit = vtResults(0)
HiLimit = vtResults(1)
End If
End If
End If
End If
ret = lStatus
DataSource = szFullyQualifiedSource
Exit Sub
ErrorHandler:
HandleError (intErrorMode)
End Sub
'*************************Find Local Object*********************************************
Public Function FindLocalObject(StartObject As Object, PartialName As String) As Object
Dim FoundObject As Object
Set FoundObject = lFindLocalObject(StartObject, PartialName)
If TypeName(FoundObject) = "Nothing" Then
MsgBox NLSStrMgr.GetNLSStr(1120, PartialName, StartObject.Name)
End If
Set FindLocalObject = FoundObject
End Function
'*************************lFind Local Object*******************************************
Private Function lFindLocalObject(StartObject As Object, PartialName As String) As Object
Dim Shape As Object
Dim MyPos As Integer
Dim i As Integer
For i = 1 To StartObject.ContainedObjects.Count
Set Shape = StartObject.ContainedObjects.Item(i)
If (Shape.ContainedObjects.Count > 0) Then
MyPos = InStr(Shape.Name, PartialName)
If (MyPos > 0) Then
Set lFindLocalObject = Shape
Exit Function
Else
Dim XObj As Object
Set XObj = lFindLocalObject(Shape, PartialName)
If TypeName(XObj) <> "Nothing" Then ' Did find the object
Set lFindLocalObject = XObj
Exit Function
End If
End If
Else
MyPos = InStr(Shape.Name, PartialName)
If (MyPos > 0) Then
Set lFindLocalObject = Shape
Exit Function
End If
End If
Next i
Set lFindLocalObject = Nothing
End Function
'*************************ParseString*******************************************
'Subroutines for Import/Export Wizard
'returns the first searchStr delimited string in the given sourceStr
' copies the remaining string and sends it back
Public Function ParseString(sourceStr As String, searchStr As String) As String
Dim iCarriageRetPos As Integer
iCarriageRetPos = InStr(1, sourceStr, searchStr)
If iCarriageRetPos <> 0 Then
ParseString = Left(sourceStr, iCarriageRetPos - 1)
sourceStr = Mid(sourceStr, iCarriageRetPos + 1)
Else
ParseString = sourceStr
sourceStr = ""
End If
End Function
'*************************IsTagGroupSyntax*******************************************
Public Function IsTagGroupSyntax(ByVal szSymbol As String)
Dim iIndex As Integer
Dim iEndIndex As Integer
Dim szTempSymbol As Integer
'Remove section of string if enclosed by quotes
iIndex = InStr(1, szSymbol, "'", vbTextCompare)
If (iIndex <> 0) Then 'looking for match
iEndIndex = InStr(iIndex + 1, szSymbol, "'", vbTextCompare)
If (iEndIndex <> 0) Then
szSymbol = Left(szSymbol, iIndex) + Mid(szSymbol, iEndIndex + 1)
End If
End If
'Look for at symbol
iIndex = InStr(1, szSymbol, "@", vbTextCompare)
If (iIndex <> 0) Then
Dim FirstLetter As String
FirstLetter = Mid(szSymbol, iIndex + 1, 1)
If (IsCharAlpha(Asc(FirstLetter)) = False) Then
IsTagGroupSyntax = False
Else
szSymbol = Mid(szSymbol, iIndex + 1)
iIndex = InStr(1, szSymbol, "@", vbTextCompare)
If (iIndex <> 0) Then
IsTagGroupSyntax = True
Else
IsTagGroupSyntax = False
End If
End If
Else
IsTagGroupSyntax = False
End If
End Function
'*************************IsUndefinedObjectSyntax*******************************************
Public Function IsUndefinedObjectSyntax(ByVal szSymbol As String)
Dim iIndex As Integer
Dim iEndIndex As Integer
Dim szTempSymbol As Integer
'Remove section of string if enclosed by quotes
iIndex = InStr(1, szSymbol, "'", vbTextCompare)
If (iIndex <> 0) Then 'looking for match
iEndIndex = InStr(iIndex + 1, szSymbol, "'", vbTextCompare)
If (iEndIndex <> 0) Then
szSymbol = Left(szSymbol, iIndex) + Mid(szSymbol, iEndIndex + 1)
End If
End If
'Look for at symbol
iIndex = InStr(1, szSymbol, "@", vbTextCompare)
If (iIndex <> 0) Then
IsUndefinedObjectSyntax = True
Else
IsUndefinedObjectSyntax = False
End If
End Function
'*************************GeneratePicture*******************************************
Public Function GeneratePicture(aPicInfo As PictureInfo) As Boolean
Dim szError As String
Dim doc As Object
Dim page As Object
On Error GoTo ErrorHandler
szError = NLSStrMgr.GetNLSStr(1121)
Set doc = Application.Documents.Add("Fix.Picture")
Set page = doc.page
If aPicInfo.lBkColor <> -1 Then
szError = NLSStrMgr.GetNLSStr(1122)
page.BackgroundColor = aPicInfo.lBkColor
End If
If aPicInfo.bPixels = True Then
Dim lfTop As Double
Dim lfLeft As Double
Dim lfHeight As Double
Dim lfWidth As Double
lfTop = aPicInfo.lfTopPct
lfLeft = aPicInfo.lfLeftPct
lfHeight = aPicInfo.lfHeightPct
lfWidth = aPicInfo.lfWidthPct
ConvertPixelToPct lfTop, lfLeft, lfHeight, lfWidth
szError = NLSStrMgr.GetNLSStr(1123)
page.setwindowlocation lfTop, lfLeft, lfHeight, lfWidth, True, True, True
Else
szError = NLSStrMgr.GetNLSStr(1123)
page.setwindowlocation aPicInfo.lfTopPct, aPicInfo.lfLeftPct, aPicInfo.lfHeightPct, aPicInfo.lfWidthPct, True, True, True
End If
szError = NLSStrMgr.GetNLSStr(1124)
page.titlebar = aPicInfo.bTitlebar
page.systemmenu = aPicInfo.bSystemMenu
page.resizable = aPicInfo.bResizable
page.alwaysontop = aPicInfo.bAlwaysOnTop
page.runtimevisible = aPicInfo.bRuntimeVisible
If aPicInfo.szName <> "" Then
szError = NLSStrMgr.GetNLSStr(1125)
doc.Name = aPicInfo.szName
doc.Save
End If
GeneratePicture = True
Exit Function
ErrorHandler:
MsgBox szError
GeneratePicture = False
End Function
'*************************ConvertPctToPixel*******************************************
Public Function ConvertPctToPixel(ByRef lfTopPct As Double, ByRef lfLeftPct As Double, lfHeightPct As Double, lfWidthPct As Double)
Dim iResX As Integer
Dim iResY As Integer
iResX = GetSystemMetrics(0)
iResY = GetSystemMetrics(1)
lfTopPct = lfTopPct / 100 * iResY
lfLeftPct = lfLeftPct / 100 * iResX
lfHeightPct = lfHeightPct / 100 * iResY
lfWidthPct = lfWidthPct / 100 * iResX
End Function
'*************************ConvertPixelToPct*******************************************
Public Function ConvertPixelToPct(lfTopPct As Double, lfLeftPct As Double, lfHeightPct As Double, lfWidthPct As Double)
Dim iResX As Integer
Dim iResY As Integer
iResX = GetSystemMetrics(0)
iResY = GetSystemMetrics(1)
lfTopPct = lfTopPct / iResY * 100
lfLeftPct = lfLeftPct / iResX * 100
lfHeightPct = lfHeightPct / iResY * 100
lfWidthPct = lfWidthPct / iResX * 100
End Function
'*************************ShowKME*******************************************
'------------------------------------------------------------------------
'
' ShowKME
' This routine is called BY NAME by the system tree right mouse
' menu when the user clicks Add Key Macro, or edit from the Key
' Macro submenu.
'
' Dependancies:
' objKMEUI - This object variable is used to reference the
' dispatch ID of the key macro server user interface
' (FDKeyMacros.exe). The server must be present
' and registered.
'
' objKMEForm - This object variable is used to reference the
' KME UI form. This is derrived from objKMEUI.
'
'
'
' Inputs:
'
' objFixObject - This object variable is used to obtain the object
' from the workspace that has the focus. It could
' be a picture, global, or shape. It is passed in
' by the right click menu or the toolbar, whichever
' the user selects to launch the KME UI.
'
' Outputs:
' NONE
'------------------------------------------------------------------------
Public Sub ShowKME(objFixObject As Object)
Dim objKMEUI As Object
Dim objKMEForm As Object
Dim szEnvWebSession As String
Dim nRetEnvWebSession As Long
nRetEnvWebSession = 0
szEnvWebSession = String(25, Chr(32))
nRetEnvWebSession = GetEnvironmentVariable("USERSESSION", szEnvWebSession, Len(szEnvWebSession) - 1)
' Priya for web client sessions. Do not launch Key macro editor for the web client sessions.
If nRetEnvWebSession > 0 Then
Exit Sub
End If
' use in-line error handling for useful messages
On Error Resume Next
' just exit if the object passed in does not support key macros
If objFixObject.KeyMacros Is Nothing Then
If Err.number > 0 Then
MsgBox NLSStrMgr.GetNLSStr(KMEERR_KMENOTSUPRTD, vbCrLf), vbExclamation Or vbOKOnly, "ShowKME()"
Exit Sub
End If
End If
' get reference to the server
Set objKMEUI = CreateObject("FDKeyMacros.clsKMEditor")
' get reference to the main form
Set objKMEForm = objKMEUI.KMESpread
If Err.number <> 0 Then
'clear the error object and raise a more descriptive one.
Err.Clear
On Error GoTo ErrHandler
Err.Raise vbObjectError + 100, , NLSStrMgr.GetNLSStr(1126, vbCr, vbLf)
End If
' send the object to the form
Set objKMEForm.TargetObject = objFixObject
If Err.number > 0 Then
DoEvents
End If
' show the form
objKMEForm.Show
If Err.number <> 0 Then
'clear the error object and raise a more descriptive one.
Err.Clear
On Error GoTo ErrHandler
Err.Raise vbObjectError + 100, , NLSStrMgr.GetNLSStr(1127, vbCr, vbLf, vbCr, vbLf)
End If
Exit Sub
ErrHandler:
HandleError
End Sub
'*************************GetActiveDocType*******************************************
Public Sub GetActiveDocType(strType As String)
Dim objActiveDoc As Object
' do inline error handling
On Error Resume Next
Set objActiveDoc = Application.ActiveDocument
If objActiveDoc Is Nothing Then
strType = "Nothing"
Exit Sub
End If
Set objActiveDoc = objActiveDoc.page
If objActiveDoc Is Nothing Then
strType = Application.ActiveDocument.Type
Else
strType = objActiveDoc.ClassName
End If
End Sub
'lad 06/29/2005 T1545 Port jes C291714 05/11/2004
'Private Sub ErrorOption(mode As Integer, number As Long, strErrorDesc As String, Optional strSource As String = "")
Public Sub ErrorOption(mode As Integer, number As Long, strErrorDesc As String, Optional strSource As String = "")
'This subroutine handles errors depending on which mode users select
' if no source was passed in, set it to the activeVBProject
If mode = 0 Then
MsgBox NLSStrMgr.GetNLSStr(1246, CStr(number), Chr(13), strErrorDesc)
ElseIf mode = 1 Then
Err.Raise number, , strErrorDesc
ElseIf mode = 2 Then
System.SendOperatorMessage strErrorDesc
End If
End Sub
Private Function NLSStrMgr() As Object 'Important! Do not move, edit, or remove this function!
Static Mgr As Object
If Mgr Is Nothing Then
Set Mgr = CreateObject("FactoryGlobalsRES.NLSStrMgr")
End If
Set NLSStrMgr = Mgr
End Function
' Passing in a boolean value will set the alarm horn property to that value
' not passing anything will just return the status
Public Function AlarmHornEnabled(Optional ByVal blnNewValue As Variant, Optional intErrMode As Integer = 0) As Boolean
If intErrMode <> 1 Then
On Error GoTo ErrorHandler
End If
' check if caller wanted to set the value
If Not IsMissing(blnNewValue) Then
System.AlarmHornEnabled = blnNewValue
End If
' return the current status
AlarmHornEnabled = System.AlarmHornEnabled
Exit Function
ErrorHandler:
HandleError
End Function
'*************************AlarmHornEnabledToggle*******************************************
' use this to toggle the alarm horn enable property
' the return value will return what it toggled to
Public Function AlarmHornEnabledToggle(Optional intErrMode As Integer = 0) As Boolean
If intErrMode <> 1 Then On Error GoTo ErrorHandler
AlarmHornEnabledToggle = AlarmHornEnabled(Not AlarmHornEnabled, intErrMode)
Exit Function
ErrorHandler:
HandleError
End Function
' Silence the alarm horn
Public Sub AlarmHornSilence(Optional intErrMode As Integer = 0)
If intErrMode <> 1 Then On Error GoTo ErrorHandler
System.SilenceAlarmHorn
Exit Sub
ErrorHandler:
HandleError
End Sub
'*************************frmSilenceAlarmHorn*******************************************
' return the form for the ability to show from a picture in run mode.
Public Property Get frmSilenceAlarmHorn() As Object
Dim frmTempForm As New frmSilenceAlarmHorn
Set frmSilenceAlarmHorn = frmTempForm
End Property
'*************************LogOut*******************************************
Public Sub LogOut()
'This subroutine is used to pop current user out
Dim strPath As String
On Error GoTo ErrorHandler
strPath = System.BasePath
strPath = strPath & "\login.exe -o"
Shell strPath, 0
Exit Sub
ErrorHandler:
HandleError
End Sub
'*************************ShowESignatureDlg*******************************************
Public Sub ShowESignatureDlg(ByRef PictureObj As Object, strSource As String, vtValue As Variant, bAckAlarm As Boolean, ByRef bPerformWrite As Boolean, Optional strZeroLabel As String = "", Optional strNonZeroLabel As String = "", Optional intErrMode As Integer = 0, Optional bValidSig As Boolean = False)
Dim eSignatureObj As Object
Dim bSignatureEnabled As Boolean
Dim bSignatureRequied As Boolean
Dim lActionType As Long
If intErrMode <> 1 Then
On Error GoTo ErrorHandler
End If
bPerformWrite = False
If bAckAlarm = False Then
lActionType = 0 'WRITE_VAL
Else
'lad 041902 Tracker #1746 need to support both alarm acknowledgement and removal
lActionType = 3 'ACK_OR_REMOVE
End If
If TypeName(PictureObj) = "Nothing" Then
' we can not put up the dialog, just exit
bPerformWrite = True
Exit Sub
End If
If PictureObj.ClassName = "Scheduler" Then
' if this function is called from schedule document, we can not put up the dialog, just exit
bPerformWrite = True
Exit Sub
End If
'JPB011003 Tracker #556 Use ESignatureFactory instead of ESignature to create
' object so that custom implementations work.
Set eSignatureObj = CreateObject("ElectronicSignature.ESignatureFactory")
eSignatureObj.IsNodeSignEnabled bSignatureEnabled
If bSignatureEnabled = True Then
eSignatureObj.Initialize strSource
eSignatureObj.IsSignatureRequired lActionType, bSignatureRequied
If bSignatureRequied = True Then
Dim bReadLabels As Boolean
If strZeroLabel = "" Then
' if no label description is supplied, set the flag to True
bReadLabels = True
Else
bReadLabels = False
End If
' Signature required
eSignatureObj.GetSignatureAndWriteValue lActionType, vtValue, bReadLabels, strZeroLabel, strNonZeroLabel, "", "", "", bValidSig
Else
' Signature not required
bPerformWrite = True
End If
Else
' Electronic Signature feature is not enabled
bPerformWrite = True
End If
Set eSignatureObj = Nothing
Exit Sub
ErrorHandler:
If Err.number <> -2147212790 Then
HandleError
End If
Set eSignatureObj = Nothing
End Sub
Public Function FixVBHelp(szHelpFile As String, dwContext As Long)
Call HtmlHelp(0, szHelpFile, &HF, dwContext)
End Function
Public Sub Get_ValuesFromTimeDefOCX(FixTimeDefControl1, AnimationObject)
' mvs07162009- test all properties!!!
On Error GoTo DefaultTimeDef
FixTimeDefControl1.HistMode = AnimationObject.HistMode
FixTimeDefControl1.StartDateMode = AnimationObject.StartDateMode
FixTimeDefControl1.StartTimeMode = AnimationObject.StartTimeMode
FixTimeDefControl1.FixedDate = AnimationObject.FixedDate
FixTimeDefControl1.FixedTime = AnimationObject.FixedTime
FixTimeDefControl1.LockStartTime = AnimationObject.LockStartTime
FixTimeDefControl1.DaysBeforeNow = AnimationObject.DaysBeforeNow
FixTimeDefControl1.TimeBeforeNow = AnimationObject.TimeBeforeNow
FixTimeDefControl1.AdjustForDST = AnimationObject.DaylightSavingsTime
FixTimeDefControl1.GlobalTimeZoneBiasRelative = AnimationObject.TimeZoneBiasRelative
FixTimeDefControl1.DurationInSeconds = AnimationObject.Duration
FixTimeDefControl1.UpdateRateInSecs = AnimationObject.HistUpdateRate
Exit Sub
DefaultTimeDef:
'Nothing to do only disalbe the ocx
If Err.number = 440 Then
FixTimeDefControl1.Enabled = False
Else
HandleError
End If
End Sub
Public Sub Put_ValuesFromTimeDefOCX(FixTimeDefControl1, AnimationObject)
' mvs07162009- test all properties!!!
Dim dFixedDateTime As Date
'Priya Do not set time def values if its OPC data source
If FixTimeDefControl1.Enabled = True Then
AnimationObject.HistMode = FixTimeDefControl1.HistMode
AnimationObject.StartDateMode = FixTimeDefControl1.StartDateMode
AnimationObject.StartTimeMode = FixTimeDefControl1.StartTimeMode
dFixedDateTime = FixTimeDefControl1.FixedDateTimeUTC
AnimationObject.FixedDateUTC = dFixedDateTime
AnimationObject.FixedTimeUTC = dFixedDateTime
If AnimationObject.StartTimeMode = HDS_Fixed Then AnimationObject.LockStartTime = FixTimeDefControl1.LockStartTime
AnimationObject.DaysBeforeNow = FixTimeDefControl1.DaysBeforeNow
AnimationObject.TimeBeforeNow = FixTimeDefControl1.TimeBeforeNow
AnimationObject.DaylightSavingsTime = FixTimeDefControl1.AdjustForDST
AnimationObject.TimeZoneBiasRelative = FixTimeDefControl1.GlobalTimeZoneBiasRelative
AnimationObject.Duration = FixTimeDefControl1.DurationInSeconds
AnimationObject.HistUpdateRate = FixTimeDefControl1.UpdateRateInSecs
End If
End Sub
Public Function ValidateDataSourceForAnimations(ByRef varExpressionObj As Object, FixTimeDefControl1) As String
Dim lStatus As Long, ValidObjects As Variant, index As Integer
Dim UndefinedObjects As Variant, strFullyQualifiedSource As String, ObjectRet As Object, lVStatus As Long
'Blank Expression gray out the TimeDef OCX
If varExpressionObj.EditText = "" Then
FixTimeDefControl1.Enabled = False
FixTimeDefControl1.Visible = True
ValidateDataSourceForAnimations = ""
Exit Function
End If
System.ParseConnectionSource "Name", varExpressionObj.EditText, lStatus, ValidObjects, UndefinedObjects, strFullyQualifiedSource
If lStatus = 0 Then
'11/06/2009 MVS #24949 - check to see if the 'ValidObjects' is empty - else it will
' throw up an error box
If TypeName(ValidObjects) = "Empty" Then
'The Data Source does not exist.
FixTimeDefControl1.Enabled = False
FixTimeDefControl1.Visible = True
Else
For index = 0 To UBound(ValidObjects)
' If Not (ValidObjects(index) Is Nothing) And ValidObjects(index).DataSourceType = 1 Then
' FixTimeDefControl1.Enabled = False
' FixTimeDefControl1.Visible = True
' ElseIf Not (ValidObjects(index) Is Nothing) And ValidObjects(index).DataSourceType = 2 Then
' FixTimeDefControl1.Enabled = True
' FixTimeDefControl1.Visible = True
' TimeDefModifyEvent FixTimeDefControl1
' ValidateDataSourceForAnimations = strFullyQualifiedSource + ";" + CStr(lStatus)
' Exit Function
' End If
'Priya TFS #24530 Use ClassName to validate data source.
If Not (ValidObjects(index) Is Nothing) And ValidObjects(index).ClassName = "CHistDataItem" Then
FixTimeDefControl1.Enabled = True
FixTimeDefControl1.Visible = True
TimeDefModifyEvent FixTimeDefControl1
ValidateDataSourceForAnimations = strFullyQualifiedSource + ";" + CStr(lStatus)
Exit Function
Else
FixTimeDefControl1.Enabled = False
FixTimeDefControl1.Visible = True
End If
Next index
End If
Else
'Validation for Tag group substitutions.
'11/06/2009 MVS #24949 - check to see if the 'UndefinedObjects' is empty - else it will
' throw up an error box
If TypeName(UndefinedObjects) = "Empty" Then
'The Data Source does not exist.
FixTimeDefControl1.Enabled = False
FixTimeDefControl1.Visible = True
Else
For index = 0 To UBound(UndefinedObjects)
System.ValidateSource CStr(UndefinedObjects(index)), lVStatus, ObjectRet, "Name"
If lVStatus = 1 Then
'This is a Tag group File
FixTimeDefControl1.Enabled = True
FixTimeDefControl1.Visible = True
TimeDefModifyEvent FixTimeDefControl1
Else
'The Data Source does not exist.
FixTimeDefControl1.Enabled = False
FixTimeDefControl1.Visible = True
End If
Next index
End If
End If
ValidateDataSourceForAnimations = strFullyQualifiedSource + ";" + CStr(lStatus)
End Function
Public Sub SetAnimationContextForOCX(FixTimeDefControl1)
FixTimeDefControl1.HistModeContext = HDS_Animations
End Sub
Public Sub TimeDefModifyEvent(FixTimeDefControl1)
If (FixTimeDefControl1.HistMode = HDS_CurrentValue) Then
FixTimeDefControl1.EnableGroup TDO_GRP_StartDate, False
FixTimeDefControl1.EnableGroup TDO_GRP_StartTime, False
FixTimeDefControl1.EnableGroup TDO_GRP_TimeZone, False
FixTimeDefControl1.EnableGroup TDO_GRP_Duration, False
FixTimeDefControl1.EnableGroup TDO_GRP_UpdateRate, True
Else
FixTimeDefControl1.EnableGroup TDO_GRP_StartDate, True
FixTimeDefControl1.EnableGroup TDO_GRP_StartTime, True
FixTimeDefControl1.EnableGroup TDO_GRP_TimeZone, True
FixTimeDefControl1.EnableGroup TDO_GRP_Duration, True
FixTimeDefControl1.EnableGroup TDO_GRP_UpdateRate, True
End If
End Sub
Public Function ValidateDataSourceStrForAnimations(strExpression As String, FixTimeDefControl1) As String
Dim lStatus As Long, ValidObjects As Variant, index As Integer
Dim UndefinedObjects As Variant, strFullyQualifiedSource As String, ObjectRet As Object, lVStatus As Long
'Blank Expression gray out the TimeDef OCX
If strExpression = "" Then
FixTimeDefControl1.Enabled = False
FixTimeDefControl1.Visible = True
ValidateDataSourceStrForAnimations = ""
Exit Function
End If
System.ParseConnectionSource "Name", strExpression, lStatus, ValidObjects, UndefinedObjects, strFullyQualifiedSource
If lStatus = 0 Then
'11/06/2009 MVS #24949 - check to see if the 'ValidObjects' is empty - else it will
' throw up an error box
If TypeName(ValidObjects) = "Empty" Then
'The Data Source does not exist.
FixTimeDefControl1.Enabled = False
FixTimeDefControl1.Visible = True
Else
For index = 0 To UBound(ValidObjects)
'Priya TFS #24530 Use ClassName to validate data source.
If Not (ValidObjects(index) Is Nothing) And ValidObjects(index).ClassName = "CHistDataItem" Then
FixTimeDefControl1.Enabled = True
FixTimeDefControl1.Visible = True
TimeDefModifyEvent FixTimeDefControl1
ValidateDataSourceStrForAnimations = strFullyQualifiedSource + ";" + CStr(lStatus)
Exit Function
Else
FixTimeDefControl1.Enabled = False
FixTimeDefControl1.Visible = True
End If
Next index
End If
Else
'Validation for Tag group substitutions.
'11/06/2009 MVS #24949 - check to see if the 'UndefinedObjects' is empty - else it will
' throw up an error box
If TypeName(UndefinedObjects) = "Empty" Then
'The Data Source does not exist.
FixTimeDefControl1.Enabled = False
FixTimeDefControl1.Visible = True
Else
For index = 0 To UBound(UndefinedObjects)
System.ValidateSource CStr(UndefinedObjects(index)), lVStatus, ObjectRet, "Name"
If lVStatus = 1 Then
'This is a Tag group File
FixTimeDefControl1.Enabled = True
FixTimeDefControl1.Visible = True
TimeDefModifyEvent FixTimeDefControl1
Else
'The Data Source does not exist.
FixTimeDefControl1.Enabled = False
FixTimeDefControl1.Visible = True
End If
Next index
End If
End If
ValidateDataSourceStrForAnimations = strFullyQualifiedSource + ";" + CStr(lStatus)
End Function
Public Function GetDataSourceTypeForHistorical(strExpression As String) As Integer
Dim lStatus As Long, ValidObjects As Variant, index As Integer
Dim UndefinedObjects As Variant, strFullyQualifiedSource As String, ObjectRet As Object, lVStatus As Long
' initialize to 0 (= unknown source or empty or n/a) - we will set it to the appropriate value later when we parse it
GetDataSourceTypeForHistorical = FGLB_UNKNOWN_DATA
'Blank Expression gray out the TimeDef OCX
If strExpression = "" Then
GetDataSourceTypeForHistorical = FGLB_NO_DATA
Exit Function
End If
' parse the connection
System.ParseConnectionSource "Name", strExpression, lStatus, ValidObjects, UndefinedObjects, strFullyQualifiedSource
If lStatus = 0 Then
'11/06/2009 MVS #24949 - check to see if the 'ValidObjects' is empty - else it will
' throw up an error box
If TypeName(ValidObjects) = "Empty" Then
'The Data Source does not exist.
GetDataSourceTypeForHistorical = FGLB_UNKNOWN_DATA
Else
For index = 0 To UBound(ValidObjects)
'Priya TFS #24530 Use ClassName to validate data source.
If Not (ValidObjects(index) Is Nothing) And ValidObjects(index).ClassName = "CHistDataItem" Then
' set to 2 (= Historical)
GetDataSourceTypeForHistorical = FGLB_HISTORICAL_DATA
Exit Function
Else
' set to 1 (= RealTime)
GetDataSourceTypeForHistorical = FGLB_REAL_TIME_DATA
End If
Next index
End If
Else
'Validation for Tag group substitutions.
'11/06/2009 MVS #24949 - check to see if the 'UndefinedObjects' is empty - else it will
' throw up an error box
If TypeName(UndefinedObjects) = "Empty" Then
'The Data Source does not exist.
GetDataSourceTypeForHistorical = FGLB_UNKNOWN_DATA
Else
For index = 0 To UBound(UndefinedObjects)
System.ValidateSource CStr(UndefinedObjects(index)), lVStatus, ObjectRet, "Name"
If lVStatus = 1 Then
'This is a Tag group File
' set to 3 (= TagGroup - so could be anything RealTime or Historical)
GetDataSourceTypeForHistorical = FGLB_TAGGROUP_DATA
Else
'The Data Source does not exist.
GetDataSourceTypeForHistorical = FGLB_UNKNOWN_DATA
End If
Next index
End If
End If
End Function