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<72>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
|
||
|