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