492 lines
13 KiB
OpenEdge ABL
492 lines
13 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 = "CApplication"
|
|
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"
|
|
|
|
|
|
'==============================================================================
|
|
'
|
|
' File : Application.cls
|
|
' Date : 06.04.1999
|
|
' Version: 1.01
|
|
' Author : Reinhard Henning, Andreas Schmidt, lindner&partner
|
|
'
|
|
'==============================================================================
|
|
'
|
|
' Hauptklasse der Anwendung
|
|
'
|
|
'==============================================================================
|
|
'
|
|
' History:
|
|
'
|
|
' Date : 06.04.1999
|
|
' Version: 1.01
|
|
' Author : Reinhard Henning, Andreas Schmidt, lindner&partner
|
|
'
|
|
' Neuer Member: m_SPS
|
|
'
|
|
' Date : 18.03.1999
|
|
' Version: 1.00
|
|
' Author : Reinhard Henning, Andreas Schmidt, lindner&partner
|
|
'
|
|
' Erste dokumentierte Version.
|
|
'
|
|
'==============================================================================
|
|
|
|
Option Explicit
|
|
|
|
' Private Member
|
|
' --------------
|
|
Private m_DB As CDBAccess
|
|
Private m_FMBus As CFMBus
|
|
Private m_Waage As CWaage
|
|
Private m_SPS As CSPS
|
|
|
|
Private m_EAKit As CEAKIT
|
|
|
|
Private m_Settings As CSettings
|
|
Private m_Mitarbeiter As CMitarbeiter
|
|
Private m_bInitialized As Boolean
|
|
|
|
Private mvarAppName As String 'lokale Kopie
|
|
Private mvarCompanyName As String 'lokale Kopie
|
|
Private mvarAppDescription As String 'lokale Kopie
|
|
Private m_PruefstationTyp As Long
|
|
Private m_PruefstationNr As Long
|
|
|
|
Public m_SIRTCOM_Statemashine As SIRTCOM.Statemashine
|
|
|
|
'Public m_frmPZP1 As Form
|
|
'Public m_frmPZP2 As Form
|
|
|
|
'Public m_SPS_OLE As CSPS_OLE
|
|
|
|
'Private Const APP_NAME$ = "Prüfstation 2000"
|
|
'Private Const APP_VERSION$ = "0.01"
|
|
'Private Const APP_DATE$ = "XX.XX.1999"
|
|
'Private Const APP_INIFILE$ = "pruef2000.ini"
|
|
|
|
Private Const APP_ShortName = "PRUEF2000"
|
|
' API declares
|
|
' ------------
|
|
Private Declare Function WNetGetUser Lib "mpr" Alias "WNetGetUserA" (ByVal lpName As String, ByVal lpusername As String, lpnLength As Long) As Long
|
|
|
|
Public Property Let CompanyName(ByVal vData As String)
|
|
'wird beim Zuweisen eines Werts zu der Eigenschaft auf der linken Seite einer Zuweisung verwendet.
|
|
'Syntax: X.CompanyName = 5
|
|
mvarCompanyName = vData
|
|
End Property
|
|
|
|
|
|
Public Property Get CompanyName() As String
|
|
'wird beim Ermitteln eines Eigenschaftswertes auf der rechten Seite einer Zuweisung verwendet.
|
|
'Syntax: Debug.Print X.CompanyName
|
|
CompanyName = mvarCompanyName
|
|
End Property
|
|
|
|
|
|
' Initialisierung der Klasse
|
|
'
|
|
Public Function initAsP2000() As Boolean
|
|
|
|
'Dim hProtool As Variant
|
|
Call modMsgBox.setStdCaption(AppName)
|
|
|
|
|
|
' Bus der FMs initialisieren
|
|
' --------------------------
|
|
frmSplash.LabelDoing = "initialising FM85P"
|
|
frmSplash.Refresh
|
|
Call initFMBus(16)
|
|
|
|
' Waage initialisieren
|
|
' --------------------
|
|
' frmSplash.LabelDoing = "initialising Waage"
|
|
' frmSplash.Refresh
|
|
'Call initWaage
|
|
|
|
' Displays initialisieren
|
|
' --------------------
|
|
frmSplash.LabelDoing = "initialising Displays"
|
|
frmSplash.Refresh
|
|
Call initEAKIT
|
|
|
|
' SPS-Objekt erzeugen
|
|
' --------------------
|
|
Set m_SPS = New CSPS
|
|
|
|
m_bInitialized = True
|
|
initAsP2000 = True
|
|
initExit:
|
|
Exit Function
|
|
End Function
|
|
|
|
Public Function get_SIRT_Statemashine(ByRef errnum As Long, ByRef errdesc As String) As SIRTCOM.Statemashine
|
|
On Error GoTo Errorhandler
|
|
|
|
If m_SIRTCOM_Statemashine Is Nothing Then
|
|
Set m_SIRTCOM_Statemashine = New SIRTCOM.Statemashine
|
|
End If
|
|
|
|
Set get_SIRT_Statemashine = m_SIRTCOM_Statemashine
|
|
Exit Function
|
|
Errorhandler:
|
|
Set get_SIRT_Statemashine = Nothing
|
|
errnum = Err.Number
|
|
errdesc = Err.Description
|
|
End Function
|
|
|
|
Public Function initAsManuell() As Boolean
|
|
' initialisiert App Objekt für manuelle Dateneingabe
|
|
' (ohne FM85, SPS, Waage...)
|
|
On Error GoTo initAsManuellError
|
|
Call modMsgBox.setStdCaption(AppName)
|
|
|
|
initAsManuell = True
|
|
m_bInitialized = True
|
|
Exit Function
|
|
initAsManuellError:
|
|
End Function
|
|
|
|
' FMBus mit FM85Ps der Prüfstation erzeugen und initialisieren
|
|
'
|
|
Private Function initFMBus(nFM85P As Integer) As Boolean
|
|
Dim fm85p As CFM85P
|
|
Dim i As Integer
|
|
|
|
On Error GoTo initFMBusErr
|
|
|
|
Set m_FMBus = New CFMBus
|
|
m_FMBus.setMScomm frmSerial.commFMBus
|
|
|
|
' FM85P-Objekte erzeugen
|
|
For i = 1 To nFM85P
|
|
If Not m_FMBus.addFM85P(0 + i) Then Exit For
|
|
Set fm85p = m_FMBus.getFM85P(i)
|
|
Call g_Logger.log(3, "OK: index: " & i & " FM85P Adresse: " & fm85p.getAdress())
|
|
Next i
|
|
|
|
initFMBus = True
|
|
Exit Function
|
|
|
|
initFMBusErr:
|
|
Exit Function
|
|
|
|
End Function
|
|
|
|
' Waage(n) der Prüfstation erzeugen und initialisieren
|
|
'
|
|
Private Function initWaage() As Boolean
|
|
'DebugMsg "initWaage() DEVPORT_Waage=" & DEVPORT_Waage
|
|
On Error GoTo initWaageErr
|
|
|
|
If g_App.Settings.getCOMPort(DEVPORT_Waage) = 0 Then
|
|
initWaage = False
|
|
Exit Function
|
|
End If
|
|
|
|
Set m_Waage = New CWaage
|
|
m_Waage.setMScomm frmSerial.commWaage
|
|
initWaage = True
|
|
Exit Function
|
|
|
|
initWaageErr:
|
|
Exit Function
|
|
End Function
|
|
|
|
'------------------------------------------------------------------------------
|
|
' Properties bzw. set/get-Funktionen
|
|
'------------------------------------------------------------------------------
|
|
|
|
' @return true = Initialisierung ist erfolgreich verlaufen,
|
|
' false = Fehler während der Initialisierung
|
|
'
|
|
Public Function IsInitialized() As Boolean
|
|
IsInitialized = m_bInitialized
|
|
End Function
|
|
|
|
|
|
Public Property Get PruefstationTyp() As Long
|
|
PruefstationTyp = m_PruefstationTyp
|
|
End Property
|
|
|
|
Public Property Let PruefstationTyp(vData As Long)
|
|
m_PruefstationTyp = vData
|
|
End Property
|
|
|
|
Public Property Get PruefstationNr() As Long
|
|
PruefstationNr = m_PruefstationNr
|
|
End Property
|
|
|
|
Public Property Let PruefstationNr(vData As Long)
|
|
m_PruefstationNr = vData
|
|
End Property
|
|
|
|
Public Property Get AppName() As String
|
|
AppName = mvarAppName
|
|
End Property
|
|
|
|
Public Property Let AppName(vData As String)
|
|
mvarAppName = vData
|
|
End Property
|
|
|
|
|
|
|
|
Public Property Get AppVersion() As String
|
|
AppVersion = App.Major & "." & App.Minor & "." & App.Revision
|
|
End Property
|
|
|
|
Public Property Get AppDate() As String
|
|
On Error Resume Next
|
|
If Dir(Me.AppPath & App.EXEName & ".exe") <> "" Then
|
|
AppDate = FileDateTime(Me.AppPath & App.EXEName & ".exe")
|
|
End If
|
|
End Property
|
|
|
|
Public Property Get AppPath() As String
|
|
If Right(App.Path, 1) = "\" Then
|
|
AppPath = App.Path
|
|
Else
|
|
AppPath = App.Path & "\"
|
|
End If
|
|
End Property
|
|
|
|
Public Property Get AppDescription() As String
|
|
AppDescription = mvarAppDescription
|
|
End Property
|
|
|
|
Public Property Let AppDescription(vData As String)
|
|
mvarAppDescription = vData
|
|
End Property
|
|
|
|
' @return Referenz auf die Server-Datenbank
|
|
'
|
|
Public Function getDB() As CDBAccess
|
|
Set getDB = m_DB
|
|
End Function
|
|
|
|
' @return Referenz auf die applikationsweiten Vorgaben
|
|
'
|
|
Public Property Get Settings() As CSettings
|
|
Set Settings = m_Settings
|
|
End Property
|
|
|
|
' Aktuellen User der Anwendung neu vorgeben
|
|
'
|
|
' @param Mitarbeiter neuer aktueller User der Anwendung
|
|
'
|
|
Public Property Let Mitarbeiter(myMitarbeiter As CMitarbeiter)
|
|
Set m_Mitarbeiter = myMitarbeiter
|
|
End Property
|
|
|
|
' @return Referenz auf den aktuell angemeldeten Mitarbeiter
|
|
'
|
|
Public Property Get Mitarbeiter() As CMitarbeiter
|
|
Set Mitarbeiter = m_Mitarbeiter
|
|
End Property
|
|
|
|
' @return Referenz auf das FMBus-Objekt der Prüfstation
|
|
'
|
|
Public Function getFMBus()
|
|
Set getFMBus = m_FMBus
|
|
End Function
|
|
|
|
' @return Referenz auf das Waage-Objekt der Prüfstation
|
|
'
|
|
Public Function getWaage() As CWaage
|
|
On Error GoTo getWaage_Error
|
|
Set getWaage = m_Waage
|
|
|
|
If m_Waage Is Nothing Then
|
|
If initWaage() = True Then
|
|
Set getWaage = m_Waage
|
|
DebugMsg "COM-PORT der Waage wird geöffnet"
|
|
m_Waage.OpenMSComm
|
|
End If
|
|
Else
|
|
Set getWaage = m_Waage
|
|
|
|
|
|
End If
|
|
|
|
If frmSerial.commWaage.PortOpen = False Then
|
|
DebugMsg "COM-PORT der Waage wird geöffnet"
|
|
m_Waage.OpenMSComm
|
|
End If
|
|
Exit Function
|
|
getWaage_Error:
|
|
'Set getWaage = Nothing
|
|
End Function
|
|
|
|
' @return Referenz auf das SPS-Objekt der Prüfstation
|
|
'
|
|
Public Function getSPS()
|
|
Set getSPS = m_SPS
|
|
End Function
|
|
|
|
' @return Name des aktuellen Windows-Users
|
|
'
|
|
Private Function getUser() As String
|
|
On Error Resume Next
|
|
Dim lpName As String
|
|
Dim mvarlpUsername As String
|
|
Const lpnLength As Integer = 255
|
|
|
|
mvarlpUsername = Space$(lpnLength + 1)
|
|
|
|
If WNetGetUser(lpName, mvarlpUsername, lpnLength) = 0 Then
|
|
getUser = Left$(mvarlpUsername, InStr(mvarlpUsername, Chr(0)) - 1)
|
|
Else
|
|
Call g_Logger.log(1, "Fehler bei der Abfrage nach der UserID. UserID = 'DEFAULT' wird angenommen.")
|
|
End If
|
|
If Err Then
|
|
DebugMsg ("Fehler bei der Abfrage nach der UserID: " & Err.Description)
|
|
End If
|
|
End Function
|
|
|
|
Public Property Get SystemPath() As String
|
|
SystemPath = GetLPRegSetting(HKEY_LOCAL_MACHINE, "Pruefstation2000", "SystemPath", REG_SZ) '& "\"
|
|
End Property
|
|
|
|
Public Property Let SystemPath(ByVal vData As String)
|
|
SaveLPRegSetting HKEY_LOCAL_MACHINE, "Pruefstation2000", "SystemPath", vData, REG_SZ
|
|
End Property
|
|
|
|
|
|
Private Sub Class_Initialize()
|
|
Dim dbuser As String
|
|
Dim dbpw As String
|
|
Dim ADOConnectionstring As String
|
|
|
|
'schon mal mit vernünftigen Werten belegen
|
|
mvarAppName = App.Title
|
|
mvarCompanyName = App.CompanyName
|
|
mvarAppDescription = App.FileDescription
|
|
|
|
Set m_Settings = New CSettings
|
|
'm_Settings.INIFilename = (AppPath() & APP_ShortName & ".INI")
|
|
m_Settings.INIFilename = (APP_ShortName & ".INI")
|
|
|
|
|
|
NeuVerbinden:
|
|
Set m_DB = New CDBAccess
|
|
|
|
ADOConnectionstring = m_Settings.ADOConnectionstring
|
|
|
|
Dim lngRet As Long
|
|
|
|
If gblnIsInIDE And InStr(1, ADOConnectionstring, "Database=Auftrag") > 0 Then
|
|
lngRet = MsgBox("Testdatenbank verwenden?", vbYesNoCancel Or vbDefaultButton1, "laufe in Entwicklungsumgebung")
|
|
If lngRet = vbYes Then
|
|
ADOConnectionstring = Replace(ADOConnectionstring, "Database=Auftrag", "Database=Testreplikation")
|
|
End If
|
|
If lngRet = vbCancel Then
|
|
End
|
|
End If
|
|
ElseIf gblnIsInIDE And InStr(1, ADOConnectionstring, "Database=Testreplikation") > 0 Then
|
|
If MsgBox("Produktiv-DB verwenden?", vbYesNo Or vbDefaultButton2, "laufe in Entwicklungsumgebung") = vbYes Then
|
|
ADOConnectionstring = Replace(ADOConnectionstring, "Database=Testreplikation", "Database=Auftrag")
|
|
End If
|
|
End If
|
|
|
|
|
|
DoEvents
|
|
If ADOConnectionstring <> "" Then
|
|
If Not m_DB.ADOConnect(ADOConnectionstring & ";Uid=PrgPruefstation;Password=PrgPruefstation") Then
|
|
MsgBox ("Die ADO-Datenbankverbindung mit" & vbCrLf & "'" & m_Settings.ADOConnectionstring & "'" & vbCrLf & "ist fehlgeschlagen. Bitte überprüfen Sie die INI-Datei '" & m_Settings.INIFilename & "'.")
|
|
End
|
|
End If
|
|
Else
|
|
MsgBox "Es ist kein ADOConnectionstring in der INI definiert"
|
|
End
|
|
' If Not m_DB.connect(dbuser, dbpw, m_Settings.ServerDBPathname, "") Then
|
|
' MsgBox ("Die Access-Datenbankverbindung mit '" & m_Settings.ServerDBPathname & "' ist fehlgeschlagen. Bitte überprüfen Sie die INI-Datei '" & m_Settings.INIFilename & "'.")
|
|
' End
|
|
' End
|
|
' End If
|
|
End If
|
|
|
|
|
|
' Mitarbeiter erzeugen
|
|
' --------------------
|
|
Set m_Mitarbeiter = New CMitarbeiter
|
|
|
|
|
|
End Sub
|
|
|
|
|
|
Public Function initEAKIT() As Boolean
|
|
Dim comport As Byte
|
|
|
|
On Error GoTo Errorhandler
|
|
If g_App.Settings.getCOMPort(DEVPORT_Display) = -1 Then
|
|
initEAKIT = False
|
|
Exit Function
|
|
End If
|
|
|
|
comport = g_App.Settings.getCOMPort(DEVPORT_Display)
|
|
|
|
If comport > 0 Then
|
|
Set m_EAKit = New CEAKIT
|
|
Debug.Print "Display Settings: " & g_App.Settings.GetDisplayCOMSettings()
|
|
m_EAKit.initMSComm frmSerial.commDisplay, comport, g_App.Settings.GetDisplayCOMSettings()
|
|
|
|
|
|
m_EAKit.Adressierung 255
|
|
m_EAKit.CallMakro 0
|
|
|
|
End If
|
|
|
|
initEAKIT = True
|
|
|
|
|
|
Exit Function
|
|
Errorhandler:
|
|
Debug.Print Err.Description
|
|
initEAKIT = False
|
|
Exit Function
|
|
Resume
|
|
End Function
|
|
|
|
Public Function GetDisplay() As CEAKIT
|
|
Set GetDisplay = m_EAKit
|
|
End Function
|
|
|
|
|
|
Public Function getAnzahlBehaelter() As Integer
|
|
Dim i As Integer
|
|
Dim Behaelter As CBehaelter
|
|
Set Behaelter = New CBehaelter
|
|
getAnzahlBehaelter = 0
|
|
For i = 1 To 10
|
|
If Behaelter.LoadFromIni(i) Then
|
|
getAnzahlBehaelter = getAnzahlBehaelter + 1
|
|
Else
|
|
Exit Function
|
|
End If
|
|
Next
|
|
End Function
|
|
|
|
|
|
Public Function GetBehaelterForVolumen(dblVolumen As Double) As CBehaelter
|
|
Dim Behaelter As CBehaelter
|
|
Set Behaelter = New CBehaelter
|
|
|
|
If Behaelter.LoadForVolumen(dblVolumen) Then
|
|
Set GetBehaelterForVolumen = Behaelter
|
|
Else
|
|
Set GetBehaelterForVolumen = Nothing
|
|
End If
|
|
End Function
|