247 lines
7.6 KiB
OpenEdge ABL
247 lines
7.6 KiB
OpenEdge ABL
VERSION 1.0 CLASS
|
|
BEGIN
|
|
MultiUse = -1 'True
|
|
Persistable = 0 'NotPersistable
|
|
DataBindingBehavior = 0 'vbNone
|
|
DataSourceBehavior = 0 'vbNone
|
|
MTSTransactionMode = 0 'NotAnMTSObject
|
|
END
|
|
Attribute VB_Name = "CProTool"
|
|
Attribute VB_GlobalNameSpace = False
|
|
Attribute VB_Creatable = True
|
|
Attribute VB_PredeclaredId = False
|
|
Attribute VB_Exposed = False
|
|
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
|
|
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
|
|
Option Explicit
|
|
|
|
' Referenz auf die ProTool Applikation
|
|
Private m_ProToolAppObj As Object
|
|
|
|
Public Function initNeu() As Boolean
|
|
On Error GoTo InitError
|
|
Set m_ProToolAppObj = GetObject(, "PTPRORUN.Document")
|
|
|
|
Debug.Print "ProTool Objekt initialisiert"
|
|
initNeu = True
|
|
Exit Function
|
|
InitError:
|
|
initNeu = False
|
|
Exit Function
|
|
|
|
End Function
|
|
|
|
' Initialilisierung des ProTool Objektes
|
|
' Return: true bei Erfolg
|
|
' False bei Fehler
|
|
Public Function init()
|
|
Dim Counter As Integer
|
|
|
|
On Error GoTo InitError
|
|
Set m_ProToolAppObj = GetObject(, "PTPRORUN.Document")
|
|
|
|
Debug.Print "ProTool Objekt initialisiert"
|
|
init = True
|
|
Exit Function
|
|
InitError:
|
|
If Counter < 120 Then
|
|
frmSplash.LabelDoing.caption = "Warte auf ProTool (" & Counter & "s): ProTool.init: " & Err.Description
|
|
DebugMsg Counter & ".Versuch: ProTool.init: " & Err.Description
|
|
DoEvents
|
|
Counter = Counter + 1
|
|
Sleep 1000, 0
|
|
Resume
|
|
Else
|
|
|
|
End If
|
|
|
|
init = False
|
|
'Set m_ProToolAppObj = Nothing Error (Err.Number)
|
|
End Function
|
|
|
|
'Public Function ProtoolAufVorhandenseinVariableTesten(ProToolVarName As String) As Boolean
|
|
' On Error GoTo Errorhandler
|
|
' Call m_ProToolAppObj.GetInstance(VarKlasse, ProToolVarName, Var)
|
|
' If Not Var Is Nothing Then
|
|
' ProtoolAufVorhandenseinVariableTesten = True
|
|
' End If
|
|
' Exit Function
|
|
'Errorhandler:
|
|
'
|
|
'End Function
|
|
|
|
|
|
Public Function VarLesen(ProToolVarName As String) As Variant
|
|
On Error GoTo VarLesenError
|
|
Dim Var As Object
|
|
Dim VarKlasse As String
|
|
Dim timedif As Long
|
|
Dim Versuch As Integer
|
|
|
|
VarKlasse = "Var"
|
|
|
|
nochmallesen:
|
|
Call m_ProToolAppObj.GetInstance(VarKlasse, ProToolVarName, Var)
|
|
' manchmal "lügt" die SPS, Vorschlag: Sleep 200, False
|
|
'-----------------------------------------------------------------------------------
|
|
' Warte max 2 Sekunden um ProTool die Zeit zu geben, um den Wert auf ungleich 0 zu aktualisieren
|
|
'timedif = GetTickCount()
|
|
'Do While Var = 0
|
|
' If GetTickCount() > timedif + 2000 Then Exit Do
|
|
'Loop
|
|
'Debug.Print "Zeitverzögerung beim Lesen der ProTool Variablen (" & ProToolVarName & "=" & Var & ") :" & GetTickCount() - timedif & " msec"
|
|
'-----------------------------------------------------------------------------------
|
|
|
|
If Not Var Is Nothing Then
|
|
VarLesen = Var
|
|
'DebugMsg "Lese ProTool(" & ProToolVarName & ")=" & CStr(Var)
|
|
Else
|
|
Versuch = Versuch + 1
|
|
|
|
If Versuch <= 3 Then
|
|
Sleep 500, True
|
|
DebugMsg "Prootool Variable " & ProToolVarName & " lesen fehlgeschlagen"
|
|
GoTo nochmallesen
|
|
End If
|
|
'ErrorMsg ("ProTool Variablen Objekt existiert nicht (mehr). Var ist nothing für ProToolVarName='" & ProToolVarName & "'")
|
|
LogIntoDB "ProTool Variablen Objekt existiert nicht (mehr). " & Versuch & " mal: Var ist nothing für ProToolVarName='" & ProToolVarName & "'", "ProTool"
|
|
VarLesen = False
|
|
End If
|
|
Exit Function
|
|
VarLesenError:
|
|
Select Case ProToolVarName
|
|
Case "PT_M1_Ist", "PT_M2_Ist", "PT_M3_Ist", "PT_M4_Ist", "PT_M5_Ist"
|
|
LogIntoDB "Fehler in ProTool.VarLesen(" & ProToolVarName & ") Variable unbekannt. Angenommen=2"
|
|
VarLesen = 2
|
|
Case Else
|
|
VarLesen = InputBox("SPS Anfrage " & vbCrLf & "Variable " & ProToolVarName & ": ", "SPS Anfrage")
|
|
LogIntoDB "Fehler in ProTool.VarLesen(" & ProToolVarName & ") Variable unbekannt. User Eingabe=" & VarLesen
|
|
End Select
|
|
End Function
|
|
|
|
'Public Function NoSysVarLesen(ProToolVarName As String) As Variant
|
|
'On Error GoTo SysVarLesenError
|
|
'Dim Var As Object
|
|
'Dim VarKlasse As String
|
|
|
|
'If m_ProToolAppObj Is Nothing Then Call init
|
|
|
|
'VarKlasse = "VarSys"
|
|
|
|
'Call m_ProToolAppObj.GetInstance(VarKlasse, ProToolVarName, Var)
|
|
|
|
'If Not Var Is Nothing Then
|
|
' SysVarLesen = Var
|
|
'Else
|
|
' MsgBox ("ProTool Variablen Objekt existiert nicht (mehr).")
|
|
' SysVarLesen = False
|
|
'End If
|
|
'Exit Function
|
|
'SysVarLesenError:
|
|
' MsgBox ("Fehler beim Lesen der ProTool,SYSVariablen: " & ProToolVarName & vbCrLf & "Err: " & Err.Description)
|
|
' SysVarLesen = False
|
|
'End Function
|
|
|
|
|
|
Public Function VarSchreiben(ProToolVarName As String, Wert As Variant) As Boolean
|
|
On Error GoTo VarSchreibenError
|
|
Dim Var As Object
|
|
|
|
Dim VarKlasse As String
|
|
Dim Versuch As Integer
|
|
|
|
Debug.Print "SPS: " & ProToolVarName & "=" & Wert
|
|
|
|
'If m_ProToolAppObj Is Nothing Then Call init
|
|
Versuch = 0
|
|
VarKlasse = "Var"
|
|
|
|
nochmalSchreiben:
|
|
Err.Clear
|
|
On Error GoTo VarSchreibenError
|
|
|
|
DebugMsg "ProTool.Varschreiben(" & ProToolVarName & "," & Wert & ") ..."
|
|
Call m_ProToolAppObj.GetInstance(VarKlasse, ProToolVarName, Var)
|
|
|
|
If Not Var Is Nothing Then
|
|
Var = CVar(Wert)
|
|
VarSchreiben = True
|
|
Else
|
|
|
|
Versuch = Versuch + 1
|
|
If Versuch <= 3 Then
|
|
Sleep 500, True
|
|
DebugMsg "Prootool Variable " & ProToolVarName & " schreiben fehlgeschlagen"
|
|
GoTo nochmalSchreiben
|
|
End If
|
|
|
|
LogIntoDB "ProTool Variablen Objekt '" & ProToolVarName & "' existiert nicht (mehr). Var is nothing.", "ProTool"
|
|
VarSchreiben = False
|
|
End If
|
|
Exit Function
|
|
VarSchreibenError:
|
|
If InStr(1, Err.Description, "Der Remote-Server-Computer existiert nicht") > 0 Then
|
|
Dim lngReturn As Long
|
|
lngReturn = MsgBox("Die Verbindung zu Protool konnte nicht hergestellt werden. Möchten Sie es nochmal versuchen? Starten Sie ggF. ProTool neu." & vbCrLf & "Klicken Sie 'Nein' zum fortfahren oder 'Abbrechen' um die Anwendung zu beenden.", vbYesNoCancel Or vbDefaultButton1, Err.Description)
|
|
Select Case lngReturn
|
|
Case vbYes
|
|
initNeu
|
|
GoTo nochmalSchreiben
|
|
Case vbCancel
|
|
If MsgBox("Möchten Sie die Anwendung wirklich beenden?", vbYesNo Or vbDefaultButton2) = vbYes Then
|
|
End
|
|
End If
|
|
End Select
|
|
End If
|
|
|
|
LogIntoDB "Fehler " & Err.Number & " beim setzen der Protool Variablen " & ProToolVarName & " auf " & Wert & ":" & Err.Description
|
|
'MsgBox ("Setzen der SPS Variablen " & vbCrLf & ProToolVarName & " = " & Wert)
|
|
|
|
' If Versuch <= 3 Then
|
|
' Sleep 500, True
|
|
' DebugMsg "Prootool Variable " & ProToolVarName & "= " & Wert & " schreiben fehlgeschlagen: " & Err.Description
|
|
'
|
|
' Versuch = Versuch + 1
|
|
' GoTo nochmalSchreiben
|
|
' End If
|
|
'
|
|
VarSchreiben = True
|
|
' VarSchreiben = False
|
|
End Function
|
|
|
|
|
|
|
|
'Public Function SysVarSchreiben(ProToolVarName As String, Wert As Variant) As Boolean
|
|
'On Error GoTo SysVarSchreibenError
|
|
'Dim Var As Object
|
|
'Dim VarKlasse As String
|
|
|
|
'If m_ProToolAppObj Is Nothing Then Call init
|
|
|
|
'VarKlasse = "VarSys"
|
|
|
|
'Call m_ProToolAppObj.GetInstance(VarKlasse, ProToolVarName, Var)
|
|
|
|
'If Not Var Is Nothing Then
|
|
' Var = Wert
|
|
' SysVarSchreiben = True
|
|
'Else
|
|
' MsgBox ("ProTool Variablen Objekt existiert nicht (mehr).")
|
|
' SysVarSchreiben = False
|
|
'End If
|
|
'Exit Function
|
|
'SysVarSchreibenError:
|
|
' MsgBox ("Fehler beim Schreiben der ProToolVariablen: " & ProToolVarName & vbCrLf & "Err: " & Err.Description)
|
|
' SysVarSchreiben = False
|
|
'End Function
|
|
|
|
Public Function QuitProTool()
|
|
On Error GoTo QuitProToolError
|
|
Call m_ProToolAppObj.Quit
|
|
Set m_ProToolAppObj = Nothing
|
|
Exit Function
|
|
QuitProToolError:
|
|
MsgBox ("ProTool konnte nicht beendet werden" & vbCrLf & Err.Description)
|
|
End Function
|
|
|