3328 lines
116 KiB
QBasic
3328 lines
116 KiB
QBasic
Attribute VB_Name = "ModMain"
|
|
'==============================================================================
|
|
'
|
|
' File : Main.bas
|
|
' Date : 18.03.1999
|
|
' Version: 1.00
|
|
' Author : Reinhard Henning, Andreas Schmidt, lindner&partner
|
|
'
|
|
'==============================================================================
|
|
'
|
|
' Startup der Anwendung
|
|
'
|
|
'==============================================================================
|
|
'
|
|
' History:
|
|
'
|
|
' Date : 18.03.1999
|
|
' Version: 1.00
|
|
' Author : Reinhard Henning, Andreas Schmidt, lindner&partner
|
|
'
|
|
' Erste dokumentierte Version.
|
|
'
|
|
'==============================================================================
|
|
|
|
Option Explicit
|
|
|
|
Global g_Logger As CLogger
|
|
Global g_DBLogConsumer As CDBLogConsumer
|
|
Global g_App As CApplication
|
|
Global g_frmMain As frmMain
|
|
Global g_Abbruch As Boolean
|
|
Global g_PrinterOK As Boolean
|
|
Global g_debug As Boolean
|
|
|
|
Global g_ohneSPS As Boolean
|
|
'eingefügt am 02.08.02 Pfeiffer
|
|
Global g_Seriennr(10) As String
|
|
Global g_strIPAdresse As String
|
|
Global g_strHostname As String
|
|
Global g_blnPruefpunkteUnsortiert As Boolean
|
|
Global g_blnPruefprotokoll As Boolean
|
|
Global g_blnVersuch As Boolean
|
|
|
|
Global g_blnSoftwarevalidierung As Boolean
|
|
|
|
Global g_PruefungLaeuft As Boolean ' für RZ Prf
|
|
|
|
Global g_MetrologAktualisieren As Boolean
|
|
|
|
Global g_varReturn As Type_Voreinstellwerte
|
|
|
|
Global g_blnMitteilungengelesen As Boolean
|
|
Global g_strErrorDesc As String
|
|
|
|
Global g_blnFertigmelden As Boolean
|
|
|
|
Global g_dblLuftTemperatur As Double
|
|
Global g_dblLuftFeuchte As Double
|
|
Global g_dblLuftDruck As Double
|
|
Global g_blnZulassungspruefung As Boolean
|
|
Global g_dblWasserdruck As Double
|
|
Global g_dblVorlauftemperatur As Double
|
|
|
|
Global g_blnganzeFluegelumrundung As Boolean
|
|
Global g_blnLWLfuerallePruefpunkte As Boolean
|
|
|
|
Global g_bln_Pruefung_nach_MID As Boolean
|
|
|
|
Global g_lngSerienNr As Long
|
|
Global g_blnPrfMitLWL As Boolean
|
|
Global g_blnPrfMitER56 As Boolean
|
|
|
|
Global g_blnKundeneigeneSerienNrAnzeigen As Boolean
|
|
|
|
Global g_strUSFW2logfileDir As String
|
|
Global g_strUSFW2logfile As String
|
|
|
|
|
|
Global g_ValuechkSensusSerNrAnzeigen As Boolean
|
|
Global g_bMeitwinMID_Sonderpruefung As Boolean
|
|
|
|
Global g_intAnzahlFW2Justage As Integer
|
|
Global g_bGetrennteJustage As Boolean
|
|
Global g_bKonfigVergleichDurchfuehren As Boolean
|
|
Global g_blnFM85log As Boolean
|
|
|
|
Global Const g_CONSTTURBOVERSUCHE = 3
|
|
|
|
|
|
Global Const BLN_BREAKPOINT = False
|
|
|
|
Global g_blnVorpruefung3malQiMittelwert As Boolean
|
|
Global g_blnbedingteQiJustage As Boolean
|
|
Global g_blnJustageWerteNICHTschreiben As Boolean
|
|
|
|
Global g_dblVolumenGrosserBehaelter As Double
|
|
Global g_ProcessId As Long
|
|
Global g_blnBefundpruefung As Boolean
|
|
Global g_blneRegisterPruefung As Boolean
|
|
Global g_blnScreenshots As Boolean
|
|
|
|
Public Type Type_Voreinstellwerte
|
|
Wert As Double
|
|
Pruefer As String
|
|
Datum As Date
|
|
Bemerkung As String
|
|
IstLetzter As Boolean
|
|
End Type
|
|
|
|
Public Type IdentNrPK
|
|
PruefklasseKZ As String
|
|
IdentNr As Long
|
|
Display As String
|
|
End Type
|
|
|
|
Private Type TFormatRange
|
|
hdc As Long
|
|
hdcTarget As Long
|
|
rc As RECT
|
|
rcPage As RECT
|
|
End Type
|
|
|
|
Const WM_USER = &H400
|
|
Const VP_FORMATRANGE = WM_USER + 125
|
|
Const VP_YESIDO = 456654
|
|
|
|
Public g_ArrayIdentNrPK() As IdentNrPK
|
|
|
|
Global bDummy As Boolean
|
|
Global lDummy As Long
|
|
|
|
Global LogFilePath As String
|
|
Global LogFileHandle As Integer
|
|
Global g_FM85RefZAdresse As Integer
|
|
|
|
Global Const SERIENNR_MINWERT = 13
|
|
Global Const SERIENNR_MAXWERT = 2147483647
|
|
|
|
|
|
Global DebugLogFilePath As String
|
|
Global gblnIsInIDE As Boolean
|
|
|
|
Public glScreenWidth As Long
|
|
Public glScreenHeight As Long
|
|
|
|
|
|
|
|
' Startup der Anwendung
|
|
'
|
|
Sub Main()
|
|
|
|
|
|
On Error GoTo Errorhandler
|
|
|
|
Dim myAppTitle As String
|
|
Dim dlgLogin As frmLogin
|
|
ReDim g_ArrayIdentNrPK(1)
|
|
Dim objSPS As CSPS
|
|
|
|
gblnIsInIDE = IsInIDE()
|
|
|
|
Call GetMyIPAdressAndHostname(g_strHostname, g_strIPAdresse)
|
|
|
|
If InStr(1, App.Path, "Pruefstation 2000 EXE") > 0 Then
|
|
LogIntoDB "Start aus " & App.Path, "Pruef2000 start"
|
|
MsgBox "Dieses Programm darf nicht aus dem Verzeichniss '" & App.Path & "' gestartet werden. Bitte wenden Sie sich an den Prüfstellenleiter, um die Software ordnungsgemäss zu installieren.", , App.EXEName
|
|
End
|
|
End If
|
|
|
|
frmSplash.Show
|
|
DoEvents
|
|
|
|
NeuVerbinden:
|
|
frmSplash.LabelDoing = "verbinden mit Datenbank..."
|
|
DoEvents
|
|
|
|
Set g_App = New CApplication
|
|
|
|
frmSplash.Label1.caption = "Datenbank: " & g_App.getDB.getConnection.DefaultDatabase
|
|
|
|
frmSplash.lblVersion = "Version " & g_App.AppVersion & " (" & g_App.Settings.Sprache & ")" _
|
|
& " (" & g_App.AppDate & ")"
|
|
frmSplash.lblCompanyProduct = g_App.AppName
|
|
|
|
App.Title = "Pruef2000"
|
|
|
|
myAppTitle = App.Title
|
|
'If g_App.Settings.getProToolString <> "" Then
|
|
' If App.PrevInstance Then
|
|
' App.Title = "2. Instance"
|
|
' AppActivate myAppTitle
|
|
' End
|
|
' End If
|
|
'End If
|
|
|
|
g_debug = True
|
|
|
|
''''''''''''''''''''''''''''''''''''''''''''''''''
|
|
' LogFile
|
|
LogFilePath = "C:\P" & Format(g_App.Settings.PruefstationNr, "0000") & "_" & Format(Now(), "yyyy-mm-dd_hh-mm-ss") & ".log"
|
|
|
|
|
|
|
|
LogFileHandle = FreeFile
|
|
WriteToLog ("----------------------------------------------------------------")
|
|
WriteToLog (" Program started:")
|
|
WriteToLog (" " & App.Path & "\" & App.EXEName & ".exe")
|
|
WriteToLog (" Version " & App.Major & "." & App.Minor & "." & App.Revision & " vom " & GetMyFileDateTimeString())
|
|
WriteToLog (" hostname: " & g_strHostname & " IP:" & g_strIPAdresse)
|
|
WriteToLog (" logdatei: " & LogFilePath)
|
|
WriteToLog ("----------------------------------------------------------------")
|
|
|
|
' x und y Auflösung
|
|
WriteToLog "Bildschirmauflösung " & Screen.Width / Screen.TwipsPerPixelX & " / " & Screen.Height / Screen.TwipsPerPixelY
|
|
|
|
If Not gblnIsInIDE Then
|
|
frmSplash.LabelDoing = "Archiviere Logdateien..."
|
|
Call LogDateienverschieben
|
|
End If
|
|
|
|
frmSplash.LabelDoing = "Anwendung auf Updates prüfen..."
|
|
DoEvents
|
|
|
|
If Not gblnIsInIDE Then
|
|
frmSplash.LabelDoing = "Prüfe auf Update..."
|
|
Call PruefeAufUpdate
|
|
End If
|
|
|
|
g_FM85RefZAdresse = g_App.Settings.FM85RefZAdresse
|
|
|
|
WriteToLog "Adresse des FM85 für RefZ Vergleich: " & g_FM85RefZAdresse
|
|
|
|
g_App.AppName = "Pruef2000"
|
|
|
|
g_App.AppDescription = "[Beschreibung der Pruefstation]"
|
|
g_App.CompanyName = "[Firmenname]"
|
|
|
|
' Splashscreen anzeigen
|
|
'frmSplash.LabelDoing = "initializing Language"
|
|
'frmSplash.Refresh
|
|
'frmSplash.Show
|
|
|
|
' Datenbank eröffnen
|
|
' ------------------
|
|
'frmSplash.LabelDoing = "initializing DBAccess"
|
|
'frmSplash.Refresh
|
|
|
|
' Primären Logger instanziieren
|
|
Set g_Logger = New CLogger
|
|
Call g_Logger.setMaxLevel(99)
|
|
|
|
|
|
|
|
' Login durchfuehren
|
|
' ------------------
|
|
frmSplash.LabelDoing = "Login"
|
|
frmSplash.Refresh
|
|
frmSplash.Show
|
|
DoEvents
|
|
Screen.MousePointer = vbDefault
|
|
Set dlgLogin = New frmLogin
|
|
If doModal(dlgLogin, True) <> IDOK Then
|
|
Call exitInstance
|
|
End If
|
|
|
|
g_App.Mitarbeiter = dlgLogin.getMitarbeiter()
|
|
|
|
LogIntoDB g_App.AppVersion, "Version"
|
|
|
|
WriteToLog "Prüfstation: " & g_App.PruefstationNr
|
|
|
|
Dim strMeldung As String
|
|
|
|
' DebugMsg "GlobaleEinstellung Pruefstation_Pruefformeln_DLL-Aktiv=" & GetGlobaleEinstellung("Pruefstation_Pruefformeln_DLL", "Aktiv")
|
|
' DebugMsg "ini Pruefstation_Pruefformeln_DLL Aktiv=" & g_App.Settings.readStringValue("Pruefstation_Pruefformeln_DLL", "Aktiv", "0")
|
|
'If (Val(GetGlobaleEinstellung("Pruefstation_Pruefformeln_DLL", "Aktiv")) = 1 Or Val(g_App.Settings.readStringValue("Pruefstation_Pruefformeln_DLL", "Aktiv", "0")) = 1) And g_App.Settings.readStringValue("Pruefstation_Pruefformeln_DLL", "Aktiv", "") <> "0" Then
|
|
' die externe Prüfformel DLL ist immer aktiv
|
|
|
|
frmSplash.LabelDoing = "Einbinden der externen Prüfformeln..."
|
|
SleepWithEvents 500, True
|
|
|
|
If Instanziere_ExternePruefformel_Objekt(strMeldung) Then
|
|
' Hat geklappt
|
|
' Name, Version und Pfad loggen
|
|
LogIntoDB g_objExternePruefformel.getName & " " & g_objExternePruefformel.GetVersion & " " & g_objExternePruefformel.GetLocation, "MEN"
|
|
DebugMsg "Eingebundene DLL " & g_objExternePruefformel.getName & " Version " & g_objExternePruefformel.GetVersion & " " & g_objExternePruefformel.GetLocation
|
|
If strMeldung <> "" Then
|
|
LogIntoDB Replace(strMeldung, vbCrLf, ""), "MEN"
|
|
End If
|
|
Else
|
|
MsgBox strMeldung & vbCrLf & vbCrLf & "Der Fehler trat beim Initialisieren der externen-Prüfformel-DLL auf." & vbCrLf & "Gegebenenfalls Prüfstellenleiter oder Programmierer benachrichtigen." & vbCrLf, vbCritical, "Fehler"
|
|
If MsgBox("Möchten Sie jetzt die Installation der externen-Prüfformel-DLL durchführen?", vbOKCancel) = vbOK Then
|
|
LogIntoDB "Installation ExternePruefformeln_Setup", "MEN"
|
|
ExecuteAndWait "\\SLA12file\Auftrag\Pruefstation 2000 EXE\ExternePruefformeln_Setup\setup.exe", "", , , True
|
|
MsgBox "Die Installation ist abgeschlossen. Bitte starten Sie die Prüfstations-Software neu!", vbInformation
|
|
End If
|
|
' Auf jeden Fall die Software neu starten
|
|
End
|
|
End If
|
|
|
|
' Applikationsobjekt instanzieren
|
|
Select Case g_App.PruefstationTyp
|
|
Case 1
|
|
If App.PrevInstance() Then
|
|
If MsgBox("Das Programm läuft bereits. Möchten Sie es für manuelle Eingaben ein weiteres mal starten?", vbYesNo Or vbDefaultButton2) = vbNo Then
|
|
End
|
|
Else
|
|
g_App.PruefstationTyp = 2
|
|
Call g_App.initAsManuell
|
|
End If
|
|
Else
|
|
App.Title = "Pruef2000"
|
|
Call g_App.initAsP2000
|
|
End If
|
|
Case 2
|
|
Call g_App.initAsManuell
|
|
Case 3
|
|
ErrorMsg ("Funktionen für PruefstationTyp = alt-automatisch sind noch nicht implementiert")
|
|
End
|
|
Case 4
|
|
ErrorMsg ("Prüfstations-Typ 4 wird von dieser Anwendung nicht unterstützt. Benutzen Sie dafür die P-20/3020 Software.")
|
|
End
|
|
Case 5
|
|
Call g_App.initAsManuell
|
|
Case 6
|
|
Call g_App.initAsManuell
|
|
Case Else
|
|
ErrorMsg "Der Typ " & g_App.PruefstationTyp & " der Applikation ist unbekannt. Bitte Wert in Ini Datei überprüfen."
|
|
End
|
|
End Select
|
|
|
|
If Not g_App.IsInitialized() Then
|
|
Call ErrorMsg("Fehler bei der Initialisierung. Die Anwendung wird jetzt beendet.")
|
|
GoTo exitMain
|
|
End If
|
|
|
|
|
|
Call CheckForNewComponentsAndSettings
|
|
Call BehaelterMaxiamlVolumenBestimmen
|
|
|
|
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
|
|
If InStr(1, LCase(g_App.Settings.ADOConnectionstring), LCase("Server=SQLSERVER")) > 0 Then
|
|
MsgBox ("Der SQL-Datenbank hat einen neuen offiziellen Namen und wird in der INI Datei umgestellt. Bitte klicken Sie OK!")
|
|
g_App.Settings.saveStringValue "Global", "ServerADOConnection", Replace(g_App.Settings.ADOConnectionstring, "Server=SQLSERVER", "Server=SLASQL01", 1, , vbTextCompare)
|
|
LogIntoDB "Datenbankserver ist nun SLASQL01", "connectionstring"
|
|
GoTo NeuVerbinden
|
|
End If
|
|
|
|
'''''''''''''''''''''''''''''''''''
|
|
|
|
If AnzahlNeueMails() > 0 Then
|
|
If g_blnMitteilungengelesen = False Then
|
|
frmMitteilungen.Show vbModal
|
|
g_blnMitteilungengelesen = True
|
|
End If
|
|
End If
|
|
|
|
' LogConsumer instanziieren, der alle Logausgaben in die Datenbank der Anwendung schreibt
|
|
Set g_DBLogConsumer = New CDBLogConsumer
|
|
Call g_Logger.addConsumer(g_DBLogConsumer)
|
|
|
|
If g_blnVersuch = False Then
|
|
If g_App.Settings.Versuch = "1" Then
|
|
g_blnVersuch = True
|
|
End If
|
|
End If
|
|
|
|
' Daten für ComboBox laden
|
|
Screen.MousePointer = vbHourglass
|
|
frmSplash.Refresh
|
|
frmSplash.Show
|
|
DoEvents
|
|
|
|
' If MsgBox("Debug Mode ?", vbYesNo Or vbDefaultButton1) = vbYes Then
|
|
' Screen.MousePointer = vbNormal
|
|
' Set g_frmMain = New frmMain
|
|
' g_ohneSPS = True
|
|
' g_frmMain.Show
|
|
' Unload frmSplash
|
|
' Exit Sub
|
|
' End If
|
|
' Rh 21.3.2006
|
|
' Call LoadIdentNrPK
|
|
|
|
Screen.MousePointer = vbNormal
|
|
|
|
Select Case g_App.PruefstationTyp
|
|
Case 1 'Normale Prüfstation 2000
|
|
'Initialisiere ProTool
|
|
|
|
frmSplash.LabelDoing = "initialisiere SPS"
|
|
frmSplash.Refresh
|
|
frmSplash.Show
|
|
DoEvents
|
|
|
|
Set g_frmMain = New frmMain
|
|
Set objSPS = g_App.getSPS
|
|
|
|
If g_App.Settings.getProToolString <> "" Then
|
|
frmSplash.LabelDoing = "initialisiere SPS ProTool"
|
|
DoEvents
|
|
objSPS.initProTool
|
|
frmSplash.LabelDoing = "check for SPS Prodave"
|
|
DoEvents
|
|
ElseIf g_App.Settings.getOpcServerUrl <> "" Then
|
|
frmSplash.LabelDoing = "initialisiere SPS Opc Server"
|
|
objSPS.initOpcServer
|
|
frmSplash.LabelDoing = "Opc Server verbunden"
|
|
ElseIf objSPS.CheckAndInitProdave() Then
|
|
' Prodave
|
|
frmSplash.LabelDoing = "Prodave initialized"
|
|
DoEvents
|
|
Else
|
|
g_ohneSPS = True
|
|
End If
|
|
|
|
'If Val(g_App.Settings.GetOrSetIniWert("Selbsttest", "disable", "0")) = 0 Then
|
|
' frmSplash.LabelDoing = "Selbsttest"
|
|
' Call SelbsttestAusfuehren
|
|
'End If
|
|
|
|
Unload frmSplash
|
|
|
|
g_frmMain.Show
|
|
g_frmMain.SetFocus
|
|
Case 2 ' Manuelle Prüfstation
|
|
g_blnVersuch = False
|
|
frmPruefzaehlerPruefungManuell.Show
|
|
Unload frmSplash
|
|
Case 3
|
|
Set g_frmMain = New frmMain
|
|
g_frmMain.Show
|
|
Case 5
|
|
Set g_frmMain = New frmMain
|
|
g_frmMain.Show
|
|
Case 6
|
|
Dim frmERegConf As New frmERegisterProgramming
|
|
frmERegConf.Show
|
|
Unload frmSplash
|
|
End Select
|
|
Exit Sub
|
|
|
|
exitMain:
|
|
End
|
|
Errorhandler:
|
|
LogIntoDB "unbehandelter Fehler " & Err.Number & " in modMain.Main: " & Err.Description, "Software Problem"
|
|
End Sub
|
|
|
|
|
|
Public Sub LoadIdentNrPK(Optional objForm As Form)
|
|
|
|
Dim Index As Long
|
|
Dim LPreset As Long
|
|
Dim rs As CRecordset
|
|
Dim sSQL As String
|
|
Dim FAKTOR As Integer
|
|
sSQL = "SELECT "
|
|
sSQL = sSQL & "IdentNr.IdentNr, "
|
|
sSQL = sSQL & "IdentNr.Bezeichnung, "
|
|
sSQL = sSQL & "IdentNr.KurzBez, "
|
|
sSQL = sSQL & "IdentNr.Typ, "
|
|
sSQL = sSQL & "IdentNr.Typzusatz, "
|
|
sSQL = sSQL & "IdentNr.Nennweite, "
|
|
sSQL = sSQL & "IdentNr.Temperatur, "
|
|
sSQL = sSQL & "IdentNr.Druck, "
|
|
sSQL = sSQL & "IdentNr.Baulaenge, "
|
|
sSQL = sSQL & "Pruefpunkte.PruefklasseKZ "
|
|
sSQL = sSQL & "FROM IdentNr "
|
|
sSQL = sSQL & "INNER JOIN Pruefpunkte ON IdentNr.IdentNr = Pruefpunkte.IdentNr order by IdentNr.KurzBez, IdentNr.Typ, IdentNr.Nennweite;"
|
|
|
|
Set rs = New CRecordset
|
|
If Not rs.openRS(sSQL) Then Exit Sub
|
|
|
|
LPreset = 0
|
|
' Globales Array definieren
|
|
|
|
g_Abbruch = False
|
|
|
|
|
|
|
|
ReDim g_ArrayIdentNrPK(0 To rs.RecordCount - 1)
|
|
FAKTOR = rs.RecordCount - 1
|
|
Do While Not rs.EOF And Not rs.BOF
|
|
g_ArrayIdentNrPK(Index).IdentNr = rs.getLongValue("IdentNr")
|
|
g_ArrayIdentNrPK(Index).PruefklasseKZ = rs.getStringValue("PruefklasseKZ")
|
|
|
|
g_ArrayIdentNrPK(Index).Display = _
|
|
rs.getStringValue("KurzBez") & " " & _
|
|
rs.getStringValue("Typ") & " " & _
|
|
IIf(Trim$(rs.getStringValue("Typzusatz")) <> "", " " & rs.getStringValue("Typzusatz"), "") & _
|
|
"DN" & Trim(CStr(rs.getLongValue("Nennweite"))) & " " & _
|
|
Trim(CStr(rs.getLongValue("Temperatur"))) & "G/PN " & _
|
|
Trim(CStr(rs.getLongValue("Druck"))) & ", L=" & _
|
|
Trim(CStr(rs.getLongValue("Baulaenge"))) & ", Klasse:" & _
|
|
rs.getStringValue("PruefklasseKZ")
|
|
|
|
Index = Index + 1
|
|
'frmSplash.LabelDoing = "Prüfvorgaben laden " & Format(Index / Faktor * 100, "###") & " %"
|
|
If Not objForm Is Nothing Then
|
|
objForm.cmdInitComboIdentNr.caption = FAKTOR - Index
|
|
End If
|
|
|
|
DoEvents
|
|
If g_Abbruch = True Then
|
|
'MsgBox "Prüfvorgaben laden wurde abgebrochen"
|
|
Exit Do
|
|
End If
|
|
rs.MoveNext
|
|
Loop
|
|
WriteToLog "Für ComboBox wurden " & Index & " IdentNr/PK geladen"
|
|
End Sub
|
|
|
|
|
|
' Programm beenden
|
|
'
|
|
Public Sub exitInstance()
|
|
On Error Resume Next
|
|
|
|
If Not g_ohneSPS Then
|
|
Dim SPS As CSPS
|
|
Set SPS = g_App.getSPS
|
|
If Not SPS Is Nothing Then
|
|
SPS.Zuruecksetzen
|
|
SPS.DisconnectSPS
|
|
End If
|
|
End If
|
|
|
|
WriteToLog "Anwendung wird beendet (exitInstance)."
|
|
End
|
|
End Sub
|
|
|
|
Public Sub Sleep(nTimeoutMillisec As Long, Optional bDoEvents As Variant = False)
|
|
Dim msEnd As Long
|
|
msEnd = GetTickCount() + nTimeoutMillisec
|
|
Do
|
|
If bDoEvents Then DoEvents
|
|
If g_Abbruch = True Then Exit Sub
|
|
Loop While GetTickCount() < msEnd
|
|
End Sub
|
|
|
|
Public Sub SleepWithEvents(nTimeoutMillisec As Long, Optional bDoEvents As Variant = False)
|
|
Dim msEnd As Long
|
|
msEnd = GetTickCount() + nTimeoutMillisec
|
|
Do
|
|
If bDoEvents Then DoEvents
|
|
Loop While GetTickCount() < msEnd
|
|
End Sub
|
|
|
|
|
|
' This routine will prevent two copies of your program from running at the
|
|
' same time. It consists of a Function that determines if another instance
|
|
' is already running and activates it if it is. The Sub (Form_Load())
|
|
' calls this function and closes the program if there is another instance
|
|
' of the program running.
|
|
Function AnotherInstance() As Boolean
|
|
Dim AppTitle$
|
|
If App.PrevInstance Then
|
|
' Hold the title of the application (title bar caption)
|
|
AppTitle$ = App.Title
|
|
' Change our application title
|
|
'App.Title = "No longer want this app running..."
|
|
' Activate the previous instance
|
|
AppActivate AppTitle$
|
|
' Let calling procedure know another instance was detected
|
|
AnotherInstance = True
|
|
Else
|
|
' Let calling procedure know another instance was NOT detected
|
|
AnotherInstance = False
|
|
End If
|
|
End Function
|
|
|
|
Public Sub PopUpMeldung(sText As String, Optional Sekunden As Variant = 15, Optional sTitel As Variant = "Pruef2000", Optional FLAGS As Variant)
|
|
|
|
Dim MeldungForm As frmMeldung
|
|
Set MeldungForm = New frmMeldung
|
|
|
|
Debug.Print sText
|
|
|
|
MeldungForm.caption = CStr(sTitel)
|
|
MeldungForm.lblMsg = sText
|
|
MeldungForm.TimeoutTimer.Interval = Sekunden * 1000
|
|
MeldungForm.TimeoutTimer.Enabled = True
|
|
|
|
MeldungForm.MousePointer = vbNormal
|
|
MeldungForm.Show vbModal
|
|
DoEvents
|
|
|
|
End Sub
|
|
|
|
' Alias for WriteToLog
|
|
Public Sub Write_DebugToLog(sText As String)
|
|
WriteToLog ("| " & sText)
|
|
End Sub
|
|
|
|
Public Sub WriteToLog(sText)
|
|
On Error GoTo Errorhandler
|
|
Debug.Print sText
|
|
|
|
If LogFilePath <> "" Then
|
|
LogFileHandle = FreeFile()
|
|
Open LogFilePath For Append As LogFileHandle
|
|
Print #LogFileHandle, Format(Now(), "dd.mm.yyyy hh.nn.ss ") & sText
|
|
Close #LogFileHandle
|
|
End If
|
|
Exit Sub
|
|
Errorhandler:
|
|
Close #LogFileHandle
|
|
End Sub
|
|
|
|
Public Sub WriteToFM85Log(sText As String, strInOut As String)
|
|
On Error GoTo Fehlerhandler
|
|
Dim strTemp As String
|
|
|
|
' sText = Replace(sText, vbCrLf, "{CrLf}")
|
|
' sText = Replace(sText, vbLf, "{Lf}")
|
|
' sText = Replace(sText, vbCr, "{Cr}")
|
|
' sText = Replace(sText, " ", "{Space}")
|
|
|
|
If g_blnFM85log = False Then Exit Sub
|
|
LogFileHandle = FreeFile()
|
|
Open "C:\fm85log.txt" For Append As LogFileHandle
|
|
strTemp = Format(Now(), "dd.mm.yyyy hh:nn:ss") & ":" & Right(Format(Timer, "0.00"), 2) & strInOut & sText
|
|
Debug.Print strTemp
|
|
Print #LogFileHandle, strTemp
|
|
Close #LogFileHandle
|
|
Fehlerhandler:
|
|
End Sub
|
|
|
|
Public Sub WriteDebugToRZLog(sText)
|
|
On Error Resume Next
|
|
Dim lngLogFileHandle As Long
|
|
Debug.Print sText
|
|
If DebugLogFilePath <> "" Then
|
|
lngLogFileHandle = FreeFile()
|
|
Open DebugLogFilePath For Append As lngLogFileHandle
|
|
Print #lngLogFileHandle, sText
|
|
Close #lngLogFileHandle
|
|
End If
|
|
End Sub
|
|
|
|
|
|
Public Sub ErrorMsg(sText As String, Optional blnKeinDBLog = False)
|
|
WriteToLog sText
|
|
If blnKeinDBLog = False Then
|
|
LogIntoDB sText, "ErrorMsg Dialog"
|
|
End If
|
|
PopUpMeldung sText, 0
|
|
End Sub
|
|
|
|
'Public Sub PrinterMsg(sText As String)
|
|
'Dim PrintFileHandle As Integer
|
|
'Dim PrintFilePath As String
|
|
'On Error Resume Next
|
|
' PrintFilePath = g_App.Settings.PrintFile
|
|
'
|
|
' Printer.FontName = "Courier"
|
|
' Printer.FontSize = 12
|
|
' Printer.Print sText
|
|
'
|
|
' If Err And PrintFilePath <> "" Then
|
|
' g_PrinterOK = False
|
|
' PrintFileHandle = FreeFile
|
|
' Open PrintFilePath For Append As PrintFileHandle
|
|
' Print #PrintFileHandle, sText
|
|
' Close #PrintFileHandle
|
|
' Else
|
|
' g_PrinterOK = True
|
|
' End If
|
|
'End Sub
|
|
|
|
Public Sub PrinterEndDoc()
|
|
Dim PrintFileHandle As Integer
|
|
Dim PrintFilePath As String
|
|
PrintFilePath = g_App.Settings.PrintFile
|
|
On Error Resume Next
|
|
Printer.EndDoc
|
|
If Err And PrintFilePath <> "" Then
|
|
PrintFileHandle = FreeFile
|
|
Open PrintFilePath For Append As PrintFileHandle
|
|
Print #PrintFileHandle, "-----------------------------------------"
|
|
Close #PrintFileHandle
|
|
End If
|
|
End Sub
|
|
|
|
Public Sub DebugMsg(sText As String)
|
|
If g_debug And sText <> "*" Then
|
|
WriteToLog sText
|
|
End If
|
|
' Debug.Print sText
|
|
End Sub
|
|
|
|
|
|
Public Sub CleanUpEnd()
|
|
exitInstance
|
|
End Sub
|
|
|
|
'
|
|
' Der ganze Rest muss hier noch raus
|
|
'
|
|
Public Function lastSlash(ByVal text As String) As Long
|
|
Dim startPos As Long
|
|
|
|
startPos = 0
|
|
While InStr(startPos + 1, text, "\") > 0
|
|
startPos = InStr(startPos + 1, text, "\")
|
|
Wend
|
|
lastSlash = startPos
|
|
End Function
|
|
|
|
Public Sub centerPicInScreen(ByRef img As Control, ByRef frm As Form)
|
|
img.Move (GetSystemMetrics(16) - img.Width) / 2, (GetSystemMetrics(17) + GetSystemMetrics(4) - img.Height) / 2
|
|
End Sub
|
|
|
|
Public Function filePath(ByRef Path As String) As String
|
|
If InStr(1, Path, "\") > 0 Then
|
|
filePath = Mid(Path, 1, InStrRev(Path, "\"))
|
|
Else
|
|
filePath = "\"
|
|
End If
|
|
End Function
|
|
|
|
Public Function filename(ByRef Path As String) As String
|
|
If InStr(1, Path, "\") > 0 Then
|
|
filename = Mid(Path, InStrRev(Path, "\") + 1)
|
|
Else
|
|
filename = Path
|
|
End If
|
|
End Function
|
|
|
|
Public Function FileExtension(ByRef Path As String) As String
|
|
If InStr(1, Path, ".") > 0 Then
|
|
'type ist vom 1. punkt bis zum ende , also auch ppt.ppx
|
|
FileExtension = Mid$(Path, InStr(Path, ".") + 1)
|
|
Else
|
|
FileExtension = ""
|
|
End If
|
|
End Function
|
|
|
|
Public Function fileNameNoExtension(ByRef filename As String) As String
|
|
If InStr(1, filename, ".") > 0 Then
|
|
'extension ist vom 1. punkt bis zum ende , also auch z.b. ppt.ppx
|
|
fileNameNoExtension = Mid(filename, 1, InStr(filename, ".") - 1)
|
|
Else
|
|
fileNameNoExtension = filename
|
|
'MsgBox "wieder keine extension"
|
|
End If
|
|
End Function
|
|
|
|
|
|
Public Function makeBmpFileName(ByRef filename As String, ByRef fileDate As String) As String
|
|
Dim myfilename As String
|
|
|
|
myfilename = filename & fileDate
|
|
myfilename = Replace(myfilename, ":", "")
|
|
myfilename = Replace(myfilename, ".", "")
|
|
myfilename = Replace(myfilename, " ", "")
|
|
|
|
makeBmpFileName = myfilename & ".bmp"
|
|
End Function
|
|
|
|
Public Function getCopyFileName(ByVal Path As String) As String
|
|
Dim fso As New FileSystemObject
|
|
Dim i As Integer
|
|
If fso.FileExists(Path) Then
|
|
i = 0
|
|
|
|
Do
|
|
If Not fso.FileExists(fileNameNoExtension(Path) & "(" & i & ")." & FileExtension(Path)) Then
|
|
getCopyFileName = fileNameNoExtension(Path) & "(" & i & ")." & FileExtension(Path)
|
|
Exit Do
|
|
Else
|
|
i = i + 1
|
|
End If
|
|
Loop
|
|
|
|
Else
|
|
getCopyFileName = Path
|
|
End If
|
|
End Function
|
|
|
|
Public Function text2hex(ByVal s As String) As String
|
|
Dim i As Integer, mystr As String, myval As Integer
|
|
For i = 1 To Len(s)
|
|
mystr = Mid(s, i, 1)
|
|
myval = Asc(mystr)
|
|
text2hex = text2hex + Hex(myval) + " "
|
|
Next i
|
|
End Function
|
|
|
|
|
|
' kg / m³
|
|
Public Function DichteVonWasser(Temperatur As Double) As Double
|
|
Dim N As Byte
|
|
Dim a(5) As Double
|
|
Dim b As Double
|
|
|
|
a(0) = 9.9983952 * 10 ^ 2
|
|
a(1) = 1.6952577 * 10 ^ (1)
|
|
a(2) = -7.9905127 * 10 ^ (-3)
|
|
a(3) = -4.6241757 * 10 ^ (-5)
|
|
a(4) = 1.0584601 * 10 ^ (-7)
|
|
a(5) = -2.8103006 * 10 ^ (-10)
|
|
b = 1.6887236 * 10 ^ (-2)
|
|
|
|
'Dichteformel
|
|
For N = 0 To 5
|
|
DichteVonWasser = DichteVonWasser + (a(N) * Temperatur ^ N)
|
|
Next N
|
|
DichteVonWasser = DichteVonWasser / (1 + b * Temperatur)
|
|
|
|
End Function
|
|
|
|
|
|
|
|
|
|
' Erweiterung für IsNumeric() schließt Leerzeichen mit ein.
|
|
Public Function IsNumericOrBlanc(sTmp As Variant) As Boolean
|
|
If IsNumeric(sTmp) Or sTmp = "" Or sTmp = "." Or sTmp = "," Then
|
|
IsNumericOrBlanc = True
|
|
End If
|
|
End Function
|
|
|
|
|
|
Public Function DebugPP(Pruefzaehler As CPruefzaehler)
|
|
Dim sPP As String
|
|
Dim Pruefpunkt As CPruefpunkt
|
|
Dim Pruefpunkte As CPruefpunkte
|
|
Dim PruefpunktCol As CPruefpunktCol
|
|
|
|
If Pruefzaehler Is Nothing Then
|
|
MsgBox ("Pruefzaehler ist nothing")
|
|
Exit Function
|
|
End If
|
|
|
|
Set Pruefpunkte = Pruefzaehler.getPruefpunkte
|
|
Set PruefpunktCol = Pruefpunkte.getPruefpunkte
|
|
|
|
For Each Pruefpunkt In PruefpunktCol.getCollection
|
|
|
|
sPP = sPP & Pruefpunkt.getQ & ", "
|
|
Next
|
|
MsgBox "Pruefpunkte: " & sPP
|
|
End Function
|
|
|
|
|
|
' Überprüfen, ob Grenzwert überschritten ist mit GERUNDETEM Fehlerwert
|
|
Public Function GrenzwertUeberschritten(FGo As Double, Fehler As Double, Fgu As Double) As Boolean
|
|
If CDbl(Format(Fehler, "0.00")) > FGo Or CDbl(Format(Fehler, "0.00")) < Fgu Then
|
|
GrenzwertUeberschritten = True
|
|
End If
|
|
End Function
|
|
|
|
|
|
Public Function lookupFUServoStellwert(Durchfluss As Double, Optional strRegelart As String = "") As Integer
|
|
Dim rs As CRecordset
|
|
Dim untererStellwert As Integer
|
|
Dim untererStellwertServo As Integer
|
|
Dim untererStellwertFU As Integer
|
|
|
|
|
|
Dim untererDurchfluss As Double
|
|
|
|
Dim obererStellwert As Integer
|
|
Dim obererStellwertServo As Integer
|
|
Dim obererStellwertFU As Integer
|
|
Dim obererDurchfluss As Double
|
|
|
|
Dim Referenzzaehler As CRefzaehler
|
|
Dim RZSerienNr As Long
|
|
|
|
Dim sSQL As String
|
|
|
|
lookupFUServoStellwert = 50
|
|
|
|
Set Referenzzaehler = New CRefzaehler
|
|
|
|
If Not Referenzzaehler.loadForDurchfluss(Durchfluss, g_App.Settings.getMIDGruppe) Then
|
|
lookupFUServoStellwert = 50
|
|
Exit Function
|
|
End If
|
|
|
|
RZSerienNr = Referenzzaehler.SerienNr
|
|
|
|
sSQL = "SELECT Durchfluss, FUStellwert, Servoposition From ReferenzzaehlerPruefpunkt "
|
|
sSQL = sSQL & "WHERE SerienNr = " & RZSerienNr & " and PflichtPruefpunkt = 1 "
|
|
sSQL = sSQL & "ORDER BY Durchfluss"
|
|
|
|
Set rs = New CRecordset
|
|
rs.openRS sSQL
|
|
Debug.Print sSQL
|
|
If Not rs.openRS(sSQL) Then Exit Function
|
|
untererStellwert = 50
|
|
obererStellwert = 50
|
|
|
|
Do While Not rs.EOF()
|
|
If rs.getDoubleValue("Durchfluss") >= Durchfluss Then Exit Do
|
|
|
|
untererDurchfluss = rs.getDoubleValue("Durchfluss")
|
|
|
|
If Not IsNull(rs.getIntValue("FUStellwert")) Then
|
|
If rs.getIntValue("FUStellwert") > 0 Then
|
|
untererStellwert = rs.getIntValue("FUStellwert")
|
|
untererStellwertFU = untererStellwert
|
|
End If
|
|
End If
|
|
|
|
If Not IsNull(rs.getIntValue("Servoposition")) Then
|
|
If rs.getIntValue("Servoposition") > 0 Then
|
|
untererStellwert = rs.getIntValue("Servoposition")
|
|
untererStellwertServo = untererStellwert
|
|
End If
|
|
End If
|
|
|
|
rs.MoveNext
|
|
Loop
|
|
|
|
If Not rs.EOF Then
|
|
obererDurchfluss = rs.getDoubleValue("Durchfluss")
|
|
|
|
If Not IsNull(rs.getIntValue("FUStellwert")) Then
|
|
If rs.getIntValue("FUStellwert") > 0 Then
|
|
obererStellwert = rs.getIntValue("FUStellwert")
|
|
obererStellwertFU = obererStellwert
|
|
End If
|
|
End If
|
|
|
|
If Not IsNull(rs.getIntValue("Servoposition")) Then
|
|
If rs.getIntValue("Servoposition") > 0 Then
|
|
obererStellwert = rs.getIntValue("Servoposition")
|
|
obererStellwertServo = obererStellwert
|
|
End If
|
|
End If
|
|
Else
|
|
DebugMsg "kein Prüfpunkt zur Ermittlung der FU/Servostellung in ReferenzzaehlerPruefpunkte gefunden. Servostellung wird 50%"
|
|
lookupFUServoStellwert = 50
|
|
Exit Function
|
|
End If
|
|
|
|
|
|
Select Case strRegelart
|
|
Case "FU"
|
|
untererStellwert = untererStellwertFU
|
|
obererStellwert = obererStellwertFU
|
|
Case "Servo"
|
|
untererStellwert = untererStellwertServo
|
|
obererStellwert = obererStellwertServo
|
|
Case Else
|
|
DebugMsg "Es wurde keine ('" & strRegelart & "') Regelart für die Funktion lookupFUServoStellwert übergeben"
|
|
End Select
|
|
|
|
' Interpolation
|
|
lookupFUServoStellwert = untererStellwert + (obererStellwert - untererStellwert) / (obererDurchfluss - untererDurchfluss) * (Durchfluss - untererDurchfluss)
|
|
|
|
End Function
|
|
|
|
|
|
|
|
Public Function FormatDateForSQL(dtmValue As Date, ByRef ADOconn As ADODB.connection) As String
|
|
|
|
If InStr(1, ADOconn.ConnectionString, "SQLOLEDB", vbTextCompare) > 0 Then
|
|
'{ d 'yyyy-mm-dd'}
|
|
FormatDateForSQL = "{d '" & Format$(dtmValue, "yyyy-mm-dd hh:nn:ss") & "'}"
|
|
Else
|
|
'FormatDateForSQL = "#" & Format$(dtmValue, "mm") & "/" & Format$(dtmValue, "dd") & "/" & Format$(dtmValue, "yyyy") & " " & Format$(dtmValue, "hh") & ":" & Format$(dtmValue, "nn") & ":" & Format$(dtmValue, "ss") & "#"
|
|
FormatDateForSQL = "cast('" & Format(dtmValue, "yyyy-mm-dd\Thh:mm:ss") & "' as datetime)"
|
|
End If
|
|
|
|
End Function
|
|
|
|
Public Function FormatsmallDateForSQL(dtmValue As Date, ByRef ADOconn As ADODB.connection) As String
|
|
|
|
If InStr(1, ADOconn.ConnectionString, "SQLOLEDB", vbTextCompare) > 0 Then
|
|
'{ d 'yyyy-mm-dd'}
|
|
FormatsmallDateForSQL = "{d '" & Format$(dtmValue, "yyyy-mm-dd hh:nn:ss") & "'}"
|
|
Else
|
|
'FormatDateForSQL = "#" & Format$(dtmValue, "mm") & "/" & Format$(dtmValue, "dd") & "/" & Format$(dtmValue, "yyyy") & " " & Format$(dtmValue, "hh") & ":" & Format$(dtmValue, "nn") & ":" & Format$(dtmValue, "ss") & "#"
|
|
FormatsmallDateForSQL = "cast('" & Format(dtmValue, "yyyy-mm-dd\Thh:mm:ss") & "' as smalldatetime)"
|
|
End If
|
|
|
|
End Function
|
|
|
|
|
|
Public Sub DoTimingLog(strText As String)
|
|
Dim PrintFileHandle As Long
|
|
PrintFileHandle = FreeFile
|
|
Open "c:\timing.log" For Append As PrintFileHandle
|
|
Print #PrintFileHandle, strText
|
|
Close #PrintFileHandle
|
|
End Sub
|
|
|
|
|
|
|
|
|
|
|
|
|
|
Public Sub LadeAuftragPositionSerienNrNeu(m_colEinbauplatz As Collection)
|
|
' RH 3.3.2006
|
|
' Bei einem Abbruch können die Prüfgang-Daten
|
|
' (Pruefgang, Prüffehler und AuftragPositionenSerienNr)gelöscht werden.
|
|
' Das Prüfzähler bzw. das zugehörige AuftragPositionSerienNr-Objekt
|
|
' hat aber die Wiederholung und das PrüfgangDatum, gespeichert.
|
|
' Deshalb müssen die Datenbank Werte neu geladen werden.
|
|
|
|
Dim Einbauplatz As CEinbauplatz
|
|
Dim Pruefzaehler As CPruefzaehler
|
|
Dim lngSerienNr As Long
|
|
|
|
DebugMsg "AuftragPositionSerienNr werden neu geladen:"
|
|
|
|
For Each Einbauplatz In m_colEinbauplatz
|
|
If Not Einbauplatz.getPruefzaehler() Is Nothing Then
|
|
Set Pruefzaehler = Einbauplatz.getPruefzaehler
|
|
lngSerienNr = Pruefzaehler.getSerienNr
|
|
|
|
DebugMsg "Wiederholung für Pruefzaehler " & lngSerienNr & " vorher=" & Pruefzaehler.getAuftragPositionSerienNr.getWiederholungen
|
|
Pruefzaehler.getAuftragPositionSerienNr.load lngSerienNr, Pruefzaehler.getAuftragPositionSerienNr.getAuftragNr
|
|
DebugMsg "Wiederholung für Pruefzaehler " & lngSerienNr & " nachher=" & Pruefzaehler.getAuftragPositionSerienNr.getWiederholungen
|
|
|
|
End If
|
|
Next
|
|
End Sub
|
|
|
|
|
|
|
|
Public Sub LogIntoDB(ByVal strText As String, Optional strKategorie As String = "")
|
|
On Error GoTo Errorhandler
|
|
Dim strSQL As String
|
|
|
|
Dim objRS As ADODB.Recordset
|
|
Set objRS = New ADODB.Recordset
|
|
|
|
|
|
strText = Left(Trim(strText), 255)
|
|
|
|
|
|
Debug.Print "LogIntoDB (" & strKategorie & "): " & strText
|
|
|
|
strSQL = "select * from PruefstationLog where Text like '%" & Left(Replace(strText, "'", "''"), 255) & "%' and Pruefstation = " & g_App.PruefstationNr & " And Anwendung ='" & App.EXEName & ".exe " & App.Major & "." & App.Minor & "." & App.Revision & " " & Format(g_App.AppDate, "dd.mm.yyyy hh:mm:ss") & "' and Hostname = '" & g_strHostname & "'"
|
|
Debug.Print strSQL
|
|
objRS.Open strSQL, g_App.getDB.getConnection, adOpenKeyset, adLockPessimistic
|
|
|
|
If objRS.EOF Then
|
|
objRS.addNew
|
|
objRS.Fields("Text").value = Left(strText, 350)
|
|
objRS.Fields("Anwendung").value = Left(App.EXEName & ".exe " & App.Major & "." & App.Minor & "." & App.Revision & " " & Format(g_App.AppDate, "dd.mm.yyyy hh:mm:ss"), 50)
|
|
objRS.Fields("Pruefer").value = g_App.Mitarbeiter.getNr
|
|
objRS.Fields("Pruefstation").value = g_App.PruefstationNr
|
|
objRS.Fields("Kategorie").value = Left(strKategorie, 20)
|
|
objRS.Fields("Datum") = Now
|
|
objRS.Fields("IPAdresse") = Left(g_strIPAdresse, 15)
|
|
objRS.Fields("Hostname") = g_strHostname
|
|
Else
|
|
objRS.Fields("Anzahl") = Val(objRS.Fields("Anzahl")) + 1
|
|
objRS.Fields("Datum") = Now
|
|
End If
|
|
objRS.update
|
|
|
|
Set objRS = Nothing
|
|
Exit Sub
|
|
Errorhandler:
|
|
DebugMsg "Fehler " & Err.Number & " in LogIntoDb: " & Err.Description
|
|
DebugMsg strText
|
|
Exit Sub
|
|
End Sub
|
|
|
|
|
|
|
|
Public Function Fehlerbyte42Meldung(varHex As Variant) As String
|
|
On Error GoTo Errorhandler
|
|
'stoer=$42 ;art der stoermeldung
|
|
' ; 0: unzul. pdauer pruef-zaehler empf.
|
|
' ; oder noch nicht empfangen oder falscher s-Befehl
|
|
' ; 1: es fehlt sendung faktor k
|
|
' ; oder fehler in sendung
|
|
' ; 2: unzul. per.zahl hauptmessg. pruef
|
|
' ; 3: unzul. per.zahl hauptmessg. ref
|
|
' ; 4: rom-fehler
|
|
' ; 5: cpu-port-fehler
|
|
' ; 6: fehler u/i-wandler
|
|
' ; 7: ram/stack-fehler
|
|
|
|
Dim byteAscWert As Byte
|
|
Dim i As Integer
|
|
|
|
If IsNumeric("&h" & Mid(CStr(varHex), 1, 2)) Then
|
|
byteAscWert = CByte("&h" & Mid(CStr(varHex), 1, 2))
|
|
|
|
For i = 0 To 7
|
|
If (byteAscWert And 2 ^ i) = 2 ^ i Then
|
|
Select Case i
|
|
Case 0
|
|
Fehlerbyte42Meldung = Fehlerbyte42Meldung & "stoer 0: unzul. pdauer pruef-zaehler empf. oder noch nicht empfangen oder falscher s-Befehl" & vbCrLf
|
|
Case 1
|
|
Fehlerbyte42Meldung = Fehlerbyte42Meldung & "stoer 1: es fehlt sendung faktor k oder fehler in sendung" & vbCrLf
|
|
Case 2
|
|
Fehlerbyte42Meldung = Fehlerbyte42Meldung & "stoer 2: unzul. per.zahl hauptmessg. pruef" & vbCrLf
|
|
Case 3
|
|
Fehlerbyte42Meldung = Fehlerbyte42Meldung & "stoer 3: unzul. per.zahl hauptmessg. ref" & vbCrLf
|
|
Case 4
|
|
Fehlerbyte42Meldung = Fehlerbyte42Meldung & "stoer 4: rom-fehler" & vbCrLf
|
|
Case 5
|
|
Fehlerbyte42Meldung = Fehlerbyte42Meldung & "stoer 5: cpu-port-fehler" & vbCrLf
|
|
Case 6
|
|
Fehlerbyte42Meldung = Fehlerbyte42Meldung & "stoer 6: fehler u/i-wandler" & vbCrLf
|
|
Case 7
|
|
Fehlerbyte42Meldung = Fehlerbyte42Meldung & "stoer 7: ram/stack-fehler" & vbCrLf
|
|
End Select
|
|
End If
|
|
Next
|
|
Else
|
|
Fehlerbyte42Meldung = "FM85 Antwort ='" & varHex & "'"
|
|
End If
|
|
Exit Function
|
|
Errorhandler:
|
|
LogIntoDB "Fehler " & Err.Number & " in Fehlerbyte42Meldung: " & Err.Description, "PrgFehler"
|
|
End Function
|
|
|
|
|
|
Public Function FM85FehlerbyteMeldung(varHex As Variant, StatusAdresse As String) As String
|
|
On Error GoTo Errorhandler
|
|
|
|
Dim byteAscWert As Byte
|
|
Dim i As Integer
|
|
|
|
byteAscWert = CByte("&h" & Mid(CStr(varHex), 1, 2)) ' Dezimaler Wert
|
|
|
|
For i = 0 To 7
|
|
If (byteAscWert And 2 ^ i) = 2 ^ i Then
|
|
Select Case StatusAdresse
|
|
Case "40"
|
|
'
|
|
'status=$40 ;merker fuer diverses
|
|
' ; 0: messwert pruef-zaehler fertig (km)
|
|
' ; 1: messwert ref-zaehler fertig (km)
|
|
' ; 2: negativer fehler kurzmessung
|
|
' ; 3: hauptmessgang pruef-zaehler laeuft
|
|
' ; 4: hauptmessgang ref-zaehler laeuft
|
|
' ; 5: hmg pruef-z. fertig
|
|
' ; 6: hmg ref-z. fertig
|
|
' ; 7: keine doppelimpulssperre
|
|
Select Case i
|
|
Case 0
|
|
FM85FehlerbyteMeldung = FM85FehlerbyteMeldung & "$40 diverses 0: messwert pruef-zaehler fertig (km)" & vbCrLf
|
|
Case 1
|
|
FM85FehlerbyteMeldung = FM85FehlerbyteMeldung & "$40 diverses 1: messwert ref-zaehler fertig (km)" & vbCrLf
|
|
Case 2
|
|
FM85FehlerbyteMeldung = FM85FehlerbyteMeldung & "$40 diverses 2: negativer fehler kurzmessung" & vbCrLf
|
|
Case 3
|
|
FM85FehlerbyteMeldung = FM85FehlerbyteMeldung & "$40 diverses 3: hauptmessgang pruef-zaehler laeuft" & vbCrLf
|
|
Case 4
|
|
FM85FehlerbyteMeldung = FM85FehlerbyteMeldung & "$40 diverses 4: hauptmessgang ref-zaehler laeuft" & vbCrLf
|
|
Case 5
|
|
FM85FehlerbyteMeldung = FM85FehlerbyteMeldung & "$40 diverses 5: hmg pruef-z. fertig" & vbCrLf
|
|
Case 6
|
|
FM85FehlerbyteMeldung = FM85FehlerbyteMeldung & "$40 diverses 6: hmg ref-z. fertig" & vbCrLf
|
|
Case 7
|
|
FM85FehlerbyteMeldung = FM85FehlerbyteMeldung & "$40 diverses 7: keine doppelimpulssperre" & vbCrLf
|
|
End Select
|
|
Case "41"
|
|
'fehler=$41 ;merker fuer diverse fehler
|
|
' ; 0: hmg pruef-z. fehlerhaft (time)
|
|
' ; 1: hmg ref-z. fehlerhaft (time)
|
|
' ; 2:
|
|
' ; 3:
|
|
' ; 4: NMI wird bearbeitet
|
|
' ; 5: DFUE-Fehler beim letzten Befehl
|
|
' ; 6: km pruef-z. fehlerhaft (time)
|
|
' ; 7: km ref-z. fehlerhaft (time)
|
|
Select Case i
|
|
Case 0
|
|
FM85FehlerbyteMeldung = FM85FehlerbyteMeldung & "$41 diverse fehler 0: hmg pruef-z. fehlerhaft (time)" & vbCrLf
|
|
Case 1
|
|
FM85FehlerbyteMeldung = FM85FehlerbyteMeldung & "$41 diverse fehler 1: hmg ref-z. fehlerhaft (time)" & vbCrLf
|
|
Case 2
|
|
FM85FehlerbyteMeldung = FM85FehlerbyteMeldung & "$41 diverse fehler 2: - " & vbCrLf
|
|
Case 3
|
|
FM85FehlerbyteMeldung = FM85FehlerbyteMeldung & "$41 diverse fehler 3: - " & vbCrLf
|
|
Case 4
|
|
FM85FehlerbyteMeldung = FM85FehlerbyteMeldung & "$41 diverse fehler 4: NMI wird bearbeitet" & vbCrLf
|
|
Case 5
|
|
FM85FehlerbyteMeldung = FM85FehlerbyteMeldung & "$41 diverse fehler 5: DFUE-Fehler beim letzten Befehl" & vbCrLf
|
|
Case 6
|
|
FM85FehlerbyteMeldung = FM85FehlerbyteMeldung & "$41 diverse fehler 6: km pruef-z. fehlerhaft (time)" & vbCrLf
|
|
Case 7
|
|
FM85FehlerbyteMeldung = FM85FehlerbyteMeldung & "$41 diverse fehler 7: km ref-z. fehlerhaft (time)" & vbCrLf
|
|
End Select
|
|
Case "42"
|
|
'stoer=$42 ;art der stoermeldung
|
|
' ; 0: unzul. pdauer pruef-zaehler empf.
|
|
' ; oder noch nicht empfangen oder falscher s-Befehl
|
|
' ; 1: es fehlt sendung faktor k
|
|
' ; oder fehler in sendung
|
|
' ; 2: unzul. per.zahl hauptmessg. pruef
|
|
' ; 3: unzul. per.zahl hauptmessg. ref
|
|
' ; 4: rom-fehler
|
|
' ; 5: cpu-port-fehler
|
|
' ; 6: fehler u/i-wandler
|
|
' ; 7: ram/stack-fehler
|
|
Select Case i
|
|
Case 0
|
|
FM85FehlerbyteMeldung = FM85FehlerbyteMeldung & "$42 stoermeldung 0: unzul. pdauer pruef-zaehler empf. oder noch nicht empfangen oder falscher s-Befehl" & vbCrLf
|
|
Case 1
|
|
FM85FehlerbyteMeldung = FM85FehlerbyteMeldung & "$42 stoermeldung 1: es fehlt sendung faktor k oder fehler in sendung" & vbCrLf
|
|
Case 2
|
|
FM85FehlerbyteMeldung = FM85FehlerbyteMeldung & "$42 stoermeldung 2: unzul. per.zahl hauptmessg. pruef" & vbCrLf
|
|
Case 3
|
|
FM85FehlerbyteMeldung = FM85FehlerbyteMeldung & "$42 stoermeldung 3: unzul. per.zahl hauptmessg. ref" & vbCrLf
|
|
Case 4
|
|
FM85FehlerbyteMeldung = FM85FehlerbyteMeldung & "$42 stoermeldung 4: rom-fehler" & vbCrLf
|
|
Case 5
|
|
FM85FehlerbyteMeldung = FM85FehlerbyteMeldung & "$42 stoermeldung 5: cpu-port-fehler" & vbCrLf
|
|
Case 6
|
|
FM85FehlerbyteMeldung = FM85FehlerbyteMeldung & "$42 stoermeldung 6: fehler u/i-wandler" & vbCrLf
|
|
Case 7
|
|
FM85FehlerbyteMeldung = FM85FehlerbyteMeldung & "$42 stoermeldung 7: ram/stack-fehler" & vbCrLf
|
|
End Select
|
|
Case "43"
|
|
'stoer1=$43 ;art der stoermeldung
|
|
' ; 0: unzul. pulszahl fuer ventil
|
|
' ; 1: hmg ref lief, aber neue werte
|
|
' ; 2: hmg pruef lief, aber neue werte
|
|
' ; 3: teiler kumm. mwbild. unzul.
|
|
' ; 4: Fehler EEPROM
|
|
' ; 5:
|
|
' ; 6:
|
|
' ; 7:
|
|
Select Case i
|
|
Case 0
|
|
FM85FehlerbyteMeldung = FM85FehlerbyteMeldung & "$43 stoermeldung 0: unzul. pulszahl fuer ventil" & vbCrLf
|
|
Case 1
|
|
FM85FehlerbyteMeldung = FM85FehlerbyteMeldung & "$43 stoermeldung 1: hmg ref lief, aber neue werte" & vbCrLf
|
|
Case 2
|
|
FM85FehlerbyteMeldung = FM85FehlerbyteMeldung & "$43 stoermeldung 2: hmg pruef lief, aber neue werte" & vbCrLf
|
|
Case 3
|
|
FM85FehlerbyteMeldung = FM85FehlerbyteMeldung & "$43 stoermeldung 3: teiler kumm. mwbild. unzul." & vbCrLf
|
|
Case 4
|
|
FM85FehlerbyteMeldung = FM85FehlerbyteMeldung & "$43 stoermeldung 4: Fehler EEPROM" & vbCrLf
|
|
Case 5
|
|
FM85FehlerbyteMeldung = FM85FehlerbyteMeldung & "$43 stoermeldung 5: -" & vbCrLf
|
|
Case 6
|
|
FM85FehlerbyteMeldung = FM85FehlerbyteMeldung & "$43 stoermeldung 6: -" & vbCrLf
|
|
Case 7
|
|
FM85FehlerbyteMeldung = FM85FehlerbyteMeldung & "$43 stoermeldung 7: - " & vbCrLf
|
|
End Select
|
|
End Select
|
|
End If
|
|
Next
|
|
Exit Function
|
|
Errorhandler:
|
|
LogIntoDB "Fehler " & Err.Number & " in Fehlerbyte42Meldung: " & Err.Description, "PrgFehler"
|
|
End Function
|
|
|
|
|
|
Public Function GibtEsEinNeuesUpdate() As Boolean
|
|
On Error GoTo Errorhandler
|
|
Dim strCurrentExePath As String
|
|
Dim strUpdateExePath As String
|
|
Dim strUpdateProgramm As String
|
|
Dim strParameter As String
|
|
Dim lngReturn As Long
|
|
|
|
' dieses Programm
|
|
strCurrentExePath = App.Path & "\" & App.EXEName & ".exe"
|
|
|
|
' Update Pfad für neue Version
|
|
strUpdateExePath = g_App.Settings.GetUpdateExePath()
|
|
If strUpdateExePath = "" Then
|
|
strUpdateExePath = "\\sla12file\Auftrag\Pruefstation 2000 EXE\Pruef2000.exe"
|
|
End If
|
|
|
|
If Dir(strUpdateExePath) = "" Then
|
|
GibtEsEinNeuesUpdate = False
|
|
Exit Function
|
|
Else
|
|
If FileDateTime(strUpdateExePath) <> FileDateTime(strCurrentExePath) Then
|
|
If FileDateTime(strUpdateExePath) > FileDateTime(strCurrentExePath) Then
|
|
GibtEsEinNeuesUpdate = True
|
|
Exit Function
|
|
ElseIf FileDateTime(strUpdateExePath) + CDbl(TimeSerial(0, 1, 0)) < FileDateTime(strCurrentExePath) Then
|
|
GibtEsEinNeuesUpdate = True
|
|
Exit Function
|
|
End If
|
|
Else
|
|
GibtEsEinNeuesUpdate = False
|
|
Exit Function
|
|
End If
|
|
End If
|
|
Exit Function
|
|
Errorhandler:
|
|
GibtEsEinNeuesUpdate = False
|
|
End Function
|
|
|
|
Public Sub PruefeAufUpdate()
|
|
On Error GoTo Errorhandler
|
|
|
|
Dim strCurrentExePath As String
|
|
Dim strUpdateExePath As String
|
|
Dim strUpdateProgramm As String
|
|
Dim strParameter As String
|
|
Dim lngReturn As Long
|
|
|
|
' If LCase(App.EXEName) = LCase("Pruef2000_Qlog") Then
|
|
' Exit Sub
|
|
' End If
|
|
|
|
' Ist Auto-Update in der Ini deaktiviert ?
|
|
If g_App.Settings.GetUpdateCheck() = "0" Then
|
|
LogIntoDB "Update Check ist in Ini ausgeschaltet.", "AutoUpdate"
|
|
DebugMsg "Update Check ist in Ini ausgeschaltet."
|
|
Exit Sub
|
|
End If
|
|
|
|
' dieses Programm
|
|
strCurrentExePath = App.Path & "\" & App.EXEName & ".exe"
|
|
|
|
Select Case LCase(App.EXEName)
|
|
Case LCase("Pruef2000"), LCase("Pruef2000_next"), LCase("Pruef2000_test"), LCase("Pruef2000_Beta")
|
|
' OK, Update durchführen
|
|
' Update Check nur für Original Exe "Pruef2000.exe"
|
|
Debug.Print LCase(App.EXEName)
|
|
Case Else
|
|
MsgBox "Für diese Anwendung kann kein automatisches Update durchgeführt werden, da die ausführbare Datei nicht 'Pruef2000.exe' heisst.", vbOKOnly, "Hinweis"
|
|
LogIntoDB "Keine Updateprüfung für '" & strCurrentExePath & "' bei Prüfstation, " & g_App.PruefstationNr & " Datei '" & strCurrentExePath & "' vom " & FileDateTime(strCurrentExePath) & "'", "AutoUpdate"
|
|
Exit Sub
|
|
End Select
|
|
|
|
' Update Pfad für neue Version
|
|
strUpdateExePath = g_App.Settings.GetUpdateExePath()
|
|
If strUpdateExePath = "" Then
|
|
strUpdateExePath = "\\sla12file\Auftrag\Pruefstation 2000 EXE\" & App.EXEName & ".exe"
|
|
'LogIntoDB "Kein Update Pfad für Prüfstation " & g_App.PruefstationNr & " in der Ini definiert. Defaultwert '" & strUpdateExePath & "' wird genommen.", "AutoUpdate"
|
|
End If
|
|
|
|
strUpdateProgramm = g_App.Settings.GetUpdateProgrammPath()
|
|
If strUpdateProgramm = "" Then
|
|
strUpdateProgramm = "\\sla12file\Auftrag\Pruefstation 2000 EXE\CopyAndStartUpdate.exe"
|
|
'LogIntoDB "Kein externes Update-Programm für Prüfstation " & g_App.PruefstationNr & " in der Ini definiert. Defaultwert '" & strUpdateProgramm & "' wird genommen.", "AutoUpdate"
|
|
End If
|
|
|
|
If Dir(strUpdateExePath) = "" Or Dir(strCurrentExePath) = "" Then
|
|
LogIntoDB "Es wurde kein Update auf '" & strUpdateExePath & "' gefunden.", "AutoUpdate"
|
|
Else
|
|
If FileDateTime(strUpdateExePath) <> FileDateTime(strCurrentExePath) Then
|
|
strParameter = """" & strUpdateExePath & """ """ & strCurrentExePath & """"
|
|
|
|
If Dir(strUpdateProgramm) = "" Then
|
|
' externer Updater wurde nicht gefunden
|
|
LogIntoDB "externer Updater '" & strUpdateProgramm & "' ist nicht vorhanden. Kein Auto-Update möglich!"
|
|
Exit Sub
|
|
End If
|
|
|
|
If FileDateTime(strUpdateExePath) > FileDateTime(strCurrentExePath) Then
|
|
If MsgBox("Es liegt neuere Version dieser Software auf dem Server vor." & vbCrLf & "ES WIRD DRINGEND EMPFOHLEN, DAS UPDATE ZU INSTALLIEREN (Bitte OK klicken!)!" & vbCrLf & "Das Programm wird nun beendet und diese Software wird aktualisert." & vbCrLf & "Server Version:" & FileDateTime(strUpdateExePath) & vbCrLf & "aktuelle Version: " & FileDateTime(strCurrentExePath), vbOKCancel, "Update") = vbOK Then
|
|
|
|
'''' start Update programm as administrator RH 16.11.2015
|
|
'''' RH 2015-11-27: runas funktioniert nicht auf XP / P2001
|
|
''''lngReturn = ShellExecute(0, "runas", strUpdateProgramm, strParameter, "", SW_SHOW)
|
|
|
|
lngReturn = ShellExecute(0, "open", strUpdateProgramm, strParameter, "", SW_SHOW)
|
|
If lngReturn = 0 Then
|
|
Err.Raise -1, , "Shell Execute gab einen Handle=0 zurück. " & strUpdateProgramm & " " & strParameter
|
|
Else
|
|
' Das Update Programm wurde erfolgreich gestartet.
|
|
' Also diese Instanz beenden, bevor das Update die .Exe überschrieben will
|
|
LogIntoDB "Update auf Version vom " & FileDateTime(strUpdateExePath), "AutoUpdate"
|
|
Call exitInstance
|
|
End
|
|
End If
|
|
Else
|
|
LogIntoDB "Update wurde abgebrochen", "AutoUpdate"
|
|
End If
|
|
|
|
ElseIf FileDateTime(strUpdateExePath) + CDbl(TimeSerial(0, 1, 0)) < FileDateTime(strCurrentExePath) Then
|
|
'mind. 1 minute älter als aktuelle
|
|
If MsgBox("Es liegt eine ältere Version dieser Software auf dem Server vor." & vbCrLf & "Möglicherweise gab es Probleme mit der neuesten Version. " & vbCrLf & "Möchten Sie das Programm nun beenden und die ältere Version installlieren?" & vbCrLf & "Server Version:" & FileDateTime(strUpdateExePath) & vbCrLf & "diese Version: " & FileDateTime(strCurrentExePath), vbYesNo Or vbDefaultButton1, "Downgrade?") = vbYes Then
|
|
lngReturn = ShellExecute(0, "open", strUpdateProgramm, strParameter, "", SW_SHOW)
|
|
If lngReturn = 0 Then
|
|
Err.Raise -1, , "Shell Execute gab einen Handle=0 zurück. " & strUpdateProgramm & " " & strParameter
|
|
Else
|
|
LogIntoDB "Downgrade auf Version vom " & FileDateTime(strUpdateExePath), "AutoUpdate"
|
|
Call exitInstance
|
|
End
|
|
End If
|
|
End If
|
|
End If
|
|
|
|
Else
|
|
'DebugMsg "kein Update erforderlich! Auf Server:" & FileDateTime(strUpdateExePath) & " Aktuell:" & FileDateTime(strCurrentExePath)
|
|
End If
|
|
End If
|
|
Exit Sub
|
|
Errorhandler:
|
|
LogIntoDB "Fehler " & Err.Number & " in PruefeAufUpdate(): " & Err.Description, "AutoUpdate Fehler"
|
|
End Sub
|
|
|
|
Public Sub PruefungFertigmeldenDialog(strMessage, colEinbauplaetze As Collection)
|
|
On Error GoTo Errorhandler
|
|
|
|
Dim ofrmFertigmeldenMAV As frmFertigmeldenMAV
|
|
Set ofrmFertigmeldenMAV = New frmFertigmeldenMAV
|
|
|
|
ofrmFertigmeldenMAV.mstrMessage = strMessage
|
|
Set ofrmFertigmeldenMAV.m_colEinbauplaetze = colEinbauplaetze
|
|
ofrmFertigmeldenMAV.Show vbModal
|
|
|
|
Exit Sub
|
|
Errorhandler:
|
|
LogIntoDB "Fehler in PruefungFertigmeldenDialog: " & Err.Description, "Test"
|
|
End Sub
|
|
|
|
|
|
Public Function FormatSerienNr(varSeriennr As Variant) As String
|
|
Dim lngSerienNr As Long
|
|
|
|
lngSerienNr = Val(varSeriennr)
|
|
If lngSerienNr > 70000000 Then
|
|
FormatSerienNr = Format(lngSerienNr, "000000000")
|
|
Else
|
|
FormatSerienNr = Str(varSeriennr)
|
|
End If
|
|
End Function
|
|
|
|
|
|
Public Function FormatDurchfluss(varDurchfluss As Variant) As String
|
|
FormatDurchfluss = CStr(Round(varDurchfluss, 5))
|
|
End Function
|
|
|
|
Public Function AppCanASPMAIL() As Boolean
|
|
On Error GoTo Errorhandler
|
|
Dim objMail As Object
|
|
' Late Binding schlägt fehl, falls DLL nicht registiert ist oder fehlt
|
|
Set objMail = CreateObject("Persits.MailSender")
|
|
AppCanASPMAIL = True
|
|
Exit Function
|
|
Errorhandler:
|
|
AppCanASPMAIL = False
|
|
End Function
|
|
|
|
|
|
Public Function AppCanActiveMail() As Boolean
|
|
On Error GoTo Errorhandler
|
|
Dim objMail As Object
|
|
' Late Binding schlägt fehl, falls DLL nicht registiert ist oder fehlt
|
|
Set objMail = CreateObject("ActiveMail.Mail")
|
|
AppCanActiveMail = True
|
|
Exit Function
|
|
Errorhandler:
|
|
AppCanActiveMail = False
|
|
End Function
|
|
|
|
|
|
Private Sub CheckForNewComponentsAndSettings()
|
|
' ' Prüft und installiert ggF. fehlende Komponenten
|
|
' ' 1) Mail
|
|
Dim strTemp As String
|
|
|
|
' If Not AppCanMail() Then
|
|
' If CopyToWinsysDirAndRegisterDll("\\sla12file\Auftrag\Pruefstation 2000 EXE\", "ActiveMail.dll") Then
|
|
' LogIntoDB "ActiveMail wurde installiert", "AutoUpdate"
|
|
' Else
|
|
' LogIntoDB "ActiveMail konnte nicht installiert werden.", "AutoUpdate"
|
|
' End If
|
|
' Else
|
|
' ' Mail OK
|
|
' End If
|
|
|
|
If Not AppCanASPMAIL() Then
|
|
If CopyToWinsysDirAndRegisterDll("\\sla12file\Auftrag\Pruefstation 2000 EXE\aspemail\", "aspemail.dll") Then
|
|
LogIntoDB "Aspemail.dll wurde installiert!", "AutoUpdate"
|
|
MsgBox ("Es wurde eine ActiveX-Komponente (ASPEMail) installiert. Damit diese funktionieren kann, muss die Preuf2000 neu gestartet werden." & vbCrLf & "Die Pruef2000 wird nun beendet.")
|
|
End
|
|
Else
|
|
LogIntoDB "Aspemail.dll konnte nicht installiert werden.", "AutoUpdate"
|
|
End If
|
|
Else
|
|
' Mail OK
|
|
End If
|
|
|
|
|
|
strTemp = g_App.Settings.readStringValue("Mail", "SMTPServer", "")
|
|
If strTemp <> "10.1.0.14" Then
|
|
g_App.Settings.saveStringValue "Mail", "SMTPServer", "10.1.0.14"
|
|
strTemp = g_App.Settings.readStringValue("Mail", "SMTPServer", "")
|
|
strTemp = "Einstellung des SMTPServers von IP 10.1.0.27 auf " & strTemp & " geändert."
|
|
LogIntoDB strTemp, "AutoUpdate"
|
|
End If
|
|
|
|
' ' meine eMail Adresse aus den Einstellungen entfernen
|
|
' If InStr(1, g_App.Settings.GetFertigmeldungEMailAdresse(), "Reinhard.henning@sensus.com") > 0 Then
|
|
' g_App.Settings.SetFertigmeldungEMailAdresse "andreas.beyer@sensus.com"
|
|
' End If
|
|
'
|
|
' Call g_App.Settings.GetOrSetIniWert("Fertigmelden", "To", "andreas.beyer@sensus.com")
|
|
'
|
|
' If InStr(1, g_App.Settings.readStringValue("HardwarePruefstation", "Kunde", ""), "Invensys") > 0 Then
|
|
' Call g_App.Settings.saveStringValue("HardwarePruefstation", "Kunde", "Sensus GmbH Hannover")
|
|
' End If
|
|
'
|
|
' wenn INI Eintrag nicht existiert, dann auf 0,2 setzen
|
|
' Call g_App.Settings.GetOrSetIniWert("Referenzzaehler", "WdhGenauigkeit", "0,2")
|
|
' If g_App.PruefstationNr = 2015 Or g_App.PruefstationNr = 2016 Then
|
|
' If g_App.Settings.GetOrSetIniWert("Waagen", "Waage1.AlleinLeeren", "") = "" Then
|
|
' LogIntoDB "WaageX.AlleinLeeren in ini geschreiben.", "AutoUpdate"
|
|
' Call g_App.Settings.GetOrSetIniWert("Waagen", "Waage1.AlleinLeeren", "1")
|
|
' Call g_App.Settings.GetOrSetIniWert("Waagen", "Waage2.AlleinLeeren", "1")
|
|
' End If
|
|
' End If
|
|
|
|
' If g_App.PruefstationNr = 2009 Or g_App.PruefstationNr = 2010 Then
|
|
' Call g_App.Settings.GetOrSetIniWert("Wetterstation", "url", "http://10.49.40.52/")
|
|
' End If
|
|
|
|
' If g_App.PruefstationNr = 2001 And False Then
|
|
' If Not IsLabjackWrapperInstalled() Then
|
|
' ' Installieren!
|
|
' If CopyToWinsysDirAndRegisterDll("\\sla12file\Auftrag\Pruefstation 2000 EXE", "LabjackWrapper.dll") Then
|
|
' LogIntoDB "LabjackWrapper dll wurde installiert", "AutoUpdate"
|
|
' Else
|
|
' LogIntoDB "LabjackWrapper dll konnte nicht installiert werden.", "AutoUpdate"
|
|
' End If
|
|
' End If
|
|
' g_App.Settings.GetOrSetIniWert "Labjack", "Wasserdruck_ID", "0"
|
|
' g_App.Settings.GetOrSetIniWert "Labjack", "Wasserdruck_Channel", "0"
|
|
' g_App.Settings.GetOrSetIniWert "Labjack", "Wasserdruck_Faktor", "0.6"
|
|
' End If
|
|
|
|
' Call SaveIniDateiToDB
|
|
Exit Sub
|
|
LogIntoDB "CheckForNewComponentsAndSettings Fehler" & Err.Number & ": " & Err.Description
|
|
End Sub
|
|
|
|
Public Function IsLabjackWrapperInstalled() As Boolean
|
|
On Error Resume Next
|
|
Dim objLabjack As Object
|
|
|
|
Set objLabjack = CreateObject("LabjackWrapper.MainClass")
|
|
If Err.Number = 0 Then
|
|
IsLabjackWrapperInstalled = True
|
|
End If
|
|
End Function
|
|
|
|
Private Sub CreateLinksAufDesktop()
|
|
|
|
On Error GoTo Errorhandler
|
|
'''''''''''''''''''''''''''''''''''''''''
|
|
Dim WshShell As Object
|
|
Dim sPath As String
|
|
Dim sLinkName As String
|
|
Dim sComment As String
|
|
Dim sFile As String
|
|
|
|
|
|
sFile = "\\sla12file\Qualitätsmanagement\Liste der QM-Dokumente\Verteilerliste QM- Dokumente.xls"
|
|
sLinkName = "Verteilerliste QM-Dokumente.lnk"
|
|
sComment = "Diese Verknüpfung öffnet die Verteilerliste der QM-Dokumente in Excel"
|
|
Set WshShell = CreateObject("WScript.Shell")
|
|
' Pfad zum Desktop-Ordner
|
|
sPath = WshShell.SpecialFolders("Desktop")
|
|
If Right$(sPath, 1) <> "\" Then sPath = sPath & "\"
|
|
Set WshShell = Nothing
|
|
|
|
If Dir(sPath & "Verteilerliste QM- Dokumente.lnk") <> "" Then
|
|
' bis zum 13.08.2007 werden die Verknüpfungen vom Desktop gelöscht
|
|
' damit sie wieder erzeugt werden können mit STRG + ALT + V
|
|
On Error Resume Next
|
|
Kill sPath & "Verteilerliste QM- Dokumente.lnk"
|
|
If Err.Number = 0 Then
|
|
LogIntoDB "'Verteilerliste QM- Dokumente.lnk' gelöscht.", "AutoUpdate"
|
|
End If
|
|
On Error GoTo Errorhandler
|
|
End If
|
|
|
|
If Dir(sPath & sLinkName) = "" Then
|
|
If CreateLink(sFile, sPath & sLinkName, "", sComment, "\\sla12file\Qualitätsmanagement\Liste der QM-Dokumente\", "Ctrl+Alt+V") = True Then
|
|
LogIntoDB "CreateLinksAufDesktop: '" & sLinkName & "' erfolgreich", "AutoUpdate"
|
|
Else
|
|
LogIntoDB "CreateLinksAufDesktop: '" & sLinkName & "' fehlgeschlagen", "AutoUpdate"
|
|
End If
|
|
Else
|
|
Debug.Print "Verknüpfung " & sLinkName & " ist vorhanden"
|
|
End If
|
|
'''''''''''''''''''''''''''''''''''''''''
|
|
|
|
|
|
sFile = "\\sla12file\Qualitätsmanagement\KZP-Liste\QV4_9A04Anlage3KZP- Liste.doc"
|
|
sLinkName = "QV4_9A04Anlage3KZP- Liste.lnk"
|
|
sComment = "Diese Verknüpfung öffnet die KZP-Liste mit Word"
|
|
Set WshShell = CreateObject("WScript.Shell")
|
|
' Pfad zum Desktop-Ordner
|
|
sPath = WshShell.SpecialFolders("Desktop")
|
|
If Right$(sPath, 1) <> "\" Then sPath = sPath & "\"
|
|
Set WshShell = Nothing
|
|
If Dir(sPath & sLinkName) = "" Then
|
|
If CreateLink(sFile, sPath & sLinkName, "", sComment, "\\sla12file\Qualitätsmanagement\KZP-Liste\", "Ctrl+Alt+K") = True Then
|
|
LogIntoDB "CreateLinksAufDesktop: QV4_9A04Anlage3KZP- Liste.lnk erfolgreich", "AutoUpdate"
|
|
Else
|
|
LogIntoDB "CreateLinksAufDesktop: QV4_9A04Anlage3KZP- Liste.lnk fehlgeschlagen", "AutoUpdate"
|
|
End If
|
|
Else
|
|
Debug.Print sPath & sLinkName & " ist vorhanden"
|
|
End If
|
|
'''''''''''''''''''''''''''''''''''''''''
|
|
|
|
Exit Sub
|
|
Errorhandler:
|
|
LogIntoDB "CreateLinksAufDesktop Fehler" & Err.Number & ": " & Err.Description
|
|
End Sub
|
|
|
|
Public Function CopyToWinsysDirAndRegisterDll(strSourceDir As String, strFileName As String) As Boolean
|
|
On Error GoTo Errorhandler
|
|
Dim lngReturn As Long
|
|
|
|
' ' Ist Datei schon vorhanden?
|
|
' If Dir(WinSysDir() & "\" & strFileName) <> "" Then
|
|
' ' also deregistrieren
|
|
' lngReturn = ShellExecute(0, "open", "regsvr32", "/s /u " & WinSysDir() & "\" & strFileName, "", SW_SHOW)
|
|
' If lngReturn = 42 Then
|
|
' ' und löschen
|
|
' Kill WinSysDir() & "\" & strFileName
|
|
' End If
|
|
' End If
|
|
|
|
Call FileCopy(strSourceDir & "\" & strFileName, WinSysDir() & "\" & strFileName)
|
|
lngReturn = ShellExecute(0, "open", "regsvr32", "/s " & WinSysDir() & "\" & strFileName, "", SW_SHOW)
|
|
If lngReturn = 42 Then
|
|
CopyToWinsysDirAndRegisterDll = True
|
|
End If
|
|
|
|
Exit Function
|
|
Errorhandler:
|
|
LogIntoDB "Fehler " & Err.Number & " CopyToWinsysDirAndRegisterDll(" & strFileName & "): " & Err.Description, "AutoUpdate"
|
|
End Function
|
|
|
|
|
|
Public Function SendASPEMail(strFrom As String, strTo As String, strSubject As String, strBody As String)
|
|
On Error GoTo Errorhandler
|
|
'Dim objMail As ActiveMail.mail
|
|
Dim objMail As Object 'ASPEMAILLib.MailSender
|
|
|
|
Dim strRecipient As Variant
|
|
|
|
If strTo = "" Then
|
|
ErrorMsg "Es wurde kein Empfänger angegeben für Mail " & strSubject
|
|
Exit Function
|
|
End If
|
|
|
|
|
|
If g_strHostname = "la--020190llb0j" Or g_strHostname = "LAA-D-CPX565J" Then
|
|
If IsInIDE() Then
|
|
Stop
|
|
End If
|
|
strTo = "reinhard.Henning@sensus.com"
|
|
End If
|
|
|
|
|
|
Set objMail = CreateObject("Persits.MailSender")
|
|
|
|
'objMail.MimeType = "text/plain; charset=ISO-8859-1" & vbCrLf & "X-Remark:"
|
|
objMail.FromName = "Pruefstation " & g_App.PruefstationNr
|
|
' Timeout in ms
|
|
objMail.Timeout = 30000
|
|
|
|
For Each strRecipient In Split(strTo, ";")
|
|
objMail.AddAddress CStr(strRecipient)
|
|
Next
|
|
|
|
objMail.From = strFrom
|
|
objMail.Subject = strSubject
|
|
objMail.Body = vbCrLf & strBody
|
|
|
|
' Todo aus Datenbank (Zentraler ini Datei)
|
|
|
|
objMail.host = g_App.Settings.GetOrSetIniWert("Mail", "SMTPServer", "")
|
|
If objMail.host = "" Then
|
|
ErrorMsg "Kein SMTP Server in Ini Datei definiert!"
|
|
Exit Function
|
|
End If
|
|
|
|
objMail.send
|
|
|
|
SendASPEMail = True
|
|
|
|
Set objMail = Nothing
|
|
|
|
Exit Function
|
|
Errorhandler:
|
|
LogIntoDB "Fehler in SendASPEMail(): Mail '" & strSubject & "' konnte nicht gesendet werden an " & strTo & ": " & Err.Number & ": " & Err.Description, "Mail"
|
|
SendASPEMail = False
|
|
Exit Function
|
|
Resume
|
|
End Function
|
|
|
|
Public Function SendMail(strFrom As String, strTo As String, strSubject As String, strBody As String) As Boolean
|
|
' Mail Verzweiger
|
|
If AppCanASPMAIL() Then
|
|
SendMail = SendASPEMail(strFrom, strTo, strSubject, strBody & vbCrLf & "gesendet mit ASPEMail")
|
|
Exit Function
|
|
Else
|
|
If AppCanActiveMail() Then
|
|
SendMail = SendActiveMail(strFrom, strTo, strSubject, strBody & vbCrLf & "gesendet mit ActiveMail")
|
|
Exit Function
|
|
Else
|
|
LogIntoDB "keine Mailkomponente installiert", "Mail"
|
|
End If
|
|
End If
|
|
End Function
|
|
|
|
Public Function SendActiveMail(strFrom As String, strTo As String, strSubject As String, strBody As String)
|
|
On Error GoTo Errorhandler
|
|
Dim objMail As ActiveMail.mail
|
|
Dim strRecipient As Variant
|
|
|
|
If strTo = "" Then
|
|
ErrorMsg "Es wurde kein Empfänger angegeben für Mail " & strSubject
|
|
Exit Function
|
|
End If
|
|
|
|
If g_strHostname = "la--020190llb0j" Then
|
|
strTo = "reinhard.Henning@sensus.com"
|
|
End If
|
|
|
|
Set objMail = CreateObject("ActiveMail.Mail")
|
|
|
|
objMail.MimeType = "text/plain; charset=ISO-8859-1" & vbCrLf & "X-Remark:"
|
|
objMail.FromName = "Pruefstation " & g_App.PruefstationNr
|
|
objMail.Timeout = 30
|
|
|
|
For Each strRecipient In Split(strTo, ";")
|
|
objMail.AddRecipient CStr(strRecipient)
|
|
Next
|
|
|
|
objMail.FromAddress = strFrom
|
|
objMail.Subject = strSubject
|
|
objMail.Body = vbCrLf & strBody
|
|
|
|
' Todo aus Datenbank (Zentraler ini Datei)
|
|
|
|
objMail.SMTPServer = g_App.Settings.GetOrSetIniWert("Mail", "SMTPServer", "")
|
|
If objMail.SMTPServer = "" Then
|
|
ErrorMsg "Kein SMTP Server in Ini Datei definiert!"
|
|
Exit Function
|
|
End If
|
|
|
|
objMail.send
|
|
|
|
If objMail.Status = "OK" Then
|
|
SendActiveMail = True
|
|
'LogIntoDB "Mail versendet an " & CStr(strTo) & ": " & strSubject
|
|
Else
|
|
LogIntoDB "Mail '" & strSubject & "'-Status " & objMail.Status, "Mail"
|
|
End If
|
|
|
|
Set objMail = Nothing
|
|
|
|
Exit Function
|
|
Errorhandler:
|
|
LogIntoDB "Mail '" & strSubject & "' konnte nicht gesendet werden an '" & strTo & "' " & Err.Number & " " & Err.Description, "Mail"
|
|
End Function
|
|
|
|
|
|
Public Function Flexgrid2Text(objMSFlexGrid As MSFlexGrid) As String
|
|
Dim Zeile As Integer
|
|
Dim Spalte As Integer
|
|
Dim Breite(10) As Integer
|
|
|
|
Flexgrid2Text = ""
|
|
|
|
For Spalte = 0 To objMSFlexGrid.Cols - 1
|
|
Breite(Spalte) = 0
|
|
For Zeile = 0 To objMSFlexGrid.Rows - 1
|
|
objMSFlexGrid.col = Spalte
|
|
objMSFlexGrid.row = Zeile
|
|
If Breite(Spalte) < Len(objMSFlexGrid.text) Then
|
|
Breite(Spalte) = Len(objMSFlexGrid.text)
|
|
End If
|
|
Next Zeile
|
|
Next Spalte
|
|
|
|
For Zeile = 0 To objMSFlexGrid.Rows - 1
|
|
For Spalte = 0 To objMSFlexGrid.Cols - 1
|
|
objMSFlexGrid.col = Spalte
|
|
objMSFlexGrid.row = Zeile
|
|
Flexgrid2Text = Flexgrid2Text & "|" & FormatSpace(objMSFlexGrid.text, Breite(Spalte))
|
|
Next
|
|
Flexgrid2Text = Flexgrid2Text & "|" & vbCrLf
|
|
If Zeile = 0 Then
|
|
For Spalte = 0 To objMSFlexGrid.Cols - 1
|
|
objMSFlexGrid.col = Spalte
|
|
objMSFlexGrid.row = Zeile
|
|
Flexgrid2Text = Flexgrid2Text & "|" & FormatSpace(Left("------------------", Breite(Spalte)), Breite(Spalte))
|
|
Next
|
|
Flexgrid2Text = Flexgrid2Text & "|" & vbCrLf
|
|
End If
|
|
Next
|
|
|
|
End Function
|
|
|
|
|
|
Public Sub ShowBegruessungsRitual()
|
|
On Error GoTo Errorhandler
|
|
|
|
frmWasIstNeu.Show vbModal
|
|
|
|
' If AnzahlNeueMails() > 0 Then
|
|
' frmMitteilungen.Show vbModal
|
|
' End If
|
|
|
|
'Call ShowRuecklaeuferOhneGrund
|
|
|
|
Exit Sub
|
|
Errorhandler:
|
|
LogIntoDB "Fehler" & Err.Number & ":" & Err.Description & " in ShowBegruessungsRitual.", "Fehler"
|
|
Exit Sub
|
|
Resume
|
|
End Sub
|
|
|
|
Private Sub ShowRuecklaeuferOhneGrund()
|
|
frmRuecklaeuferOhneGrund.Show vbModal
|
|
End Sub
|
|
|
|
|
|
Public Function AnzahlNeueMails() As Long
|
|
Dim strSQL As String
|
|
Dim rs As CRecordset
|
|
|
|
strSQL = "SELECT * from Mitteilungen "
|
|
strSQL = strSQL & "WHERE NachrichtID NOT IN (SELECT NachrichtID FROM GeleseneMitteilungen WHERE MitarbeiterNr = " & g_App.Mitarbeiter.getNr & ") "
|
|
strSQL = strSQL & "ORDER BY Mitteilungen.Datum DESC "
|
|
|
|
Set rs = New CRecordset
|
|
rs.openRS strSQL, True
|
|
|
|
|
|
' If g_App.Mitarbeiter.getNr = 10 Then
|
|
' ' Reinhard Henning
|
|
' AnzahlNeueMails = 0
|
|
' Exit Function
|
|
' End If
|
|
|
|
|
|
AnzahlNeueMails = rs.RecordCount
|
|
|
|
End Function
|
|
|
|
Public Function HatMitarbeiterRecht(strRecht) As Boolean
|
|
Dim strSQL As String
|
|
Dim rs As CRecordset
|
|
Dim lngMitarbeiterNr As Long
|
|
|
|
lngMitarbeiterNr = g_App.Mitarbeiter.getNr
|
|
|
|
If InStr(1, g_App.getDB.getConnection.DefaultDatabase, "Testreplikation") > 0 Then
|
|
' Testdatenbank: Recht "TEST" darf alles
|
|
strSQL = "SELECT * from MitarbeiterRechte where MitarbeiterNr = " & lngMitarbeiterNr & " AND (Recht='" & strRecht & "' OR Recht='TEST')"
|
|
ElseIf InStr(1, g_App.getDB.getConnection.ConnectionString, "Auftrag") > 0 Then
|
|
' Produktivdatenbank
|
|
strSQL = "SELECT * from MitarbeiterRechte where MitarbeiterNr = " & lngMitarbeiterNr & " AND (Recht='" & strRecht & "' OR Recht='SUPERUSER')"
|
|
Else
|
|
HatMitarbeiterRecht = False
|
|
Exit Function
|
|
End If
|
|
|
|
Set rs = New CRecordset
|
|
rs.openRS strSQL, True
|
|
If Not rs.EOF Then
|
|
HatMitarbeiterRecht = True
|
|
End If
|
|
|
|
End Function
|
|
|
|
|
|
|
|
Public Function getextension(filename As String) As String
|
|
Dim pos As Integer
|
|
Dim i As Integer
|
|
Dim C As String
|
|
|
|
For i = Len(filename) To 2 Step -1
|
|
C = Mid(filename, i, 1)
|
|
If C = "." Then
|
|
pos = i + 1
|
|
End If
|
|
Next
|
|
If pos > 0 Then
|
|
getextension = Mid(filename, pos, (Len(filename) + 1 - pos))
|
|
Else
|
|
getextension = ""
|
|
End If
|
|
End Function
|
|
|
|
|
|
'Function to get filetitle from full path
|
|
Public Function getfiletitle(filename As String) As String
|
|
Dim i As Integer
|
|
Dim C As String
|
|
Dim pos As Integer
|
|
|
|
For i = Len(filename) To 2 Step -1
|
|
C = Mid(filename, i, 1)
|
|
If C = "\" Then
|
|
pos = i + 1
|
|
End If
|
|
Next
|
|
getfiletitle = Mid(filename, pos, (Len(filename) + 1 - pos))
|
|
End Function
|
|
|
|
|
|
Public Function AddTextInPosition(strText As String, strNeuerText As String, Position As Integer) As String
|
|
AddTextInPosition = Left(strText & Space(Position), Position) & strNeuerText
|
|
If Len(strText) > Position + Len(strNeuerText) Then
|
|
AddTextInPosition = Left(AddTextInPosition, Len(strNeuerText) + Position) + Mid(strText, Position)
|
|
End If
|
|
End Function
|
|
|
|
Public Sub AutoSpaltenBreite(flexgrid As MSFlexGrid, SizeLbl As Label, Optional AbSpaltegleicheBreite As Long = 0, Optional AbZeile As Long = 0, Optional NurVergroessern As Boolean = False)
|
|
Dim Spalte As Long
|
|
Dim Zeile As Integer
|
|
Dim Breite As Double
|
|
Dim maxBreite As Double
|
|
|
|
With flexgrid
|
|
' Font-Eigenschaften des Flexgrids auf Label
|
|
' übertragen
|
|
SizeLbl.Font = .Font
|
|
SizeLbl.FontSize = .Font.Size
|
|
SizeLbl.FontItalic = .Font.Italic
|
|
SizeLbl.FontBold = .Font.Bold
|
|
|
|
' Autosize des Labels aktivieren und Label
|
|
' ausblenden
|
|
SizeLbl.AutoSize = True
|
|
SizeLbl.Visible = False
|
|
|
|
' Aktualisierung des Flexgrids verhindern, bis
|
|
' Vorgang abgeschlossen ist
|
|
.Redraw = False
|
|
|
|
' Flexgrid spaltenweise "abtasten"...
|
|
For Spalte = 0 To .Cols - 1
|
|
' ermittelte Höchstbreite vor jedem
|
|
' Spaltendurchlauf zurücksetzen
|
|
Breite = 0
|
|
|
|
' Alle Zeilen der aktuellen Spalte durchlaufen...
|
|
For Zeile = AbZeile To .Rows - 1
|
|
' Inhalt der aktuellen Zelle in Label schreiben...
|
|
SizeLbl.caption = .TextMatrix(Zeile, Spalte)
|
|
' Ist die aktuelle Breite des Labels größer als die
|
|
' bisher ermittelte höchste Breite ?
|
|
If SizeLbl.Width > Breite Then
|
|
' Ja, dann Breite in VAR Breite ablegen
|
|
Breite = SizeLbl.Width
|
|
End If
|
|
Next Zeile
|
|
' Wenn alle Zeilen der aktuellen Spalte durchlaufen sind,
|
|
' ermittelte höchste Spaltenbreite als optimale Spaltenbreite
|
|
' der aktuellen Zeile des Flexgrids setzen
|
|
If Spalte >= AbSpaltegleicheBreite Then
|
|
If maxBreite < Breite Then
|
|
maxBreite = Breite
|
|
End If
|
|
End If
|
|
|
|
.ColWidth(Spalte) = Breite * 1.1
|
|
|
|
Next Spalte
|
|
|
|
If AbSpaltegleicheBreite > 0 Then
|
|
For Spalte = AbSpaltegleicheBreite To .Cols - 1
|
|
If NurVergroessern Then
|
|
If .ColWidth(Spalte) < maxBreite * 1.1 Then
|
|
.ColWidth(Spalte) = maxBreite * 1.1
|
|
End If
|
|
Else
|
|
.ColWidth(Spalte) = maxBreite * 1.1
|
|
End If
|
|
Next
|
|
End If
|
|
' Aktualiaierung des Flexgrids wieder zulassen
|
|
.Redraw = True
|
|
End With
|
|
End Sub
|
|
|
|
|
|
|
|
' Verknüpfung erstellen
|
|
Public Function CreateLink(ByVal sFile As String, _
|
|
ByVal sLinkName As String, _
|
|
Optional ByVal sParameter As String = "", _
|
|
Optional ByVal sComment As String = "", _
|
|
Optional ByVal sWorkingDir As String = "", _
|
|
Optional ByVal sHotKey As String) As Boolean
|
|
|
|
' Fehlerbehandlung, falls WSH-Objekt nicht
|
|
' verfügbar
|
|
On Error GoTo ErrHandler
|
|
Dim WshShell As Object
|
|
Dim WshLink As Object
|
|
|
|
' Verweis auf den Windows Scripting Host erstellen
|
|
Set WshShell = CreateObject("WScript.Shell")
|
|
|
|
' Neuen Link Erstellen
|
|
Set WshLink = WshShell.CreateShortcut(sLinkName)
|
|
|
|
With WshLink
|
|
' Ziel der Verknüpfung
|
|
.TargetPath = sFile
|
|
|
|
' Weitere Eigenschaften...
|
|
.WorkingDirectory = sWorkingDir
|
|
.Arguments = sParameter
|
|
.Description = sComment
|
|
.HotKey = sHotKey
|
|
|
|
' Verknüpfung speichern
|
|
.save
|
|
End With
|
|
|
|
' Objekte zerstören
|
|
Set WshLink = Nothing
|
|
Set WshShell = Nothing
|
|
CreateLink = True
|
|
On Error GoTo 0
|
|
Exit Function
|
|
ErrHandler:
|
|
CreateLink = False
|
|
End Function
|
|
|
|
Public Sub InstalliereErweiterungen()
|
|
Dim LRes As Long
|
|
Dim cFileName As String
|
|
Dim cDirName As String
|
|
Dim cResult As String
|
|
Dim cExecute As String
|
|
Dim strMessage As String
|
|
|
|
cDirName = "\\sla12file\Auftrag\Pruefstation 2000 EXE\Viewer\"
|
|
cResult = Space$(128)
|
|
cFileName = "Test.xls"
|
|
|
|
LRes = FindExecutable(cFileName, cDirName, cResult)
|
|
cExecute = Mid$(cResult, 1, InStr(1, cResult, Chr(0)) - 1)
|
|
If Len(cExecute) > 0 Then
|
|
' es existiert eine Anwendung
|
|
LogIntoDB "bereits installiert: " & cExecute, "AutoUpdate"
|
|
Else
|
|
strMessage = "Auf diesem PC ist keine Anwendung zum Öffnen von Excel-Dateien installiert." & vbCrLf
|
|
strMessage = strMessage & "Der Excel Viewer wird benötigt, damit Sie QM-Dokumente aus einer Mitteilung öffnen können." & vbCrLf
|
|
strMessage = strMessage & "Bitte installieren Sie jetzt den Excel Viewer." & vbCrLf & vbCrLf
|
|
strMessage = strMessage & "Möchten Sie jetzt das Excel-Viewer Setup starten ?"
|
|
If MsgBox(strMessage, vbOKCancel Or vbDefaultButton1, "Nachfrage zur Installation des Excel Viewers") = vbOK Then
|
|
LogIntoDB "Excelviewer Setup gestartet", "AutoUpdate"
|
|
LRes = Shell("\\sla12file\Auftrag\Pruefstation 2000 EXE\Viewer\XLVIEWER.EXE", vbNormalFocus)
|
|
MsgBox "Weiter nach der Installation des Excel-Viewers...", vbOKOnly, "Weiter ?"
|
|
End If
|
|
End If
|
|
|
|
cDirName = "\\sla12file\Auftrag\Pruefstation 2000 EXE\Viewer\"
|
|
cResult = Space$(128)
|
|
cFileName = "Test.doc"
|
|
|
|
LRes = FindExecutable(cFileName, cDirName, cResult)
|
|
cExecute = Mid$(cResult, 1, InStr(1, cResult, Chr(0)) - 1)
|
|
If InStr(1, cExecute, "WINWORD.EXE") > 0 Or InStr(1, cExecute, "WORDVIEW.EXE") > 0 Then
|
|
LogIntoDB "bereits installiert: " & cExecute, "AutoUpdate"
|
|
Else
|
|
strMessage = "Auf diesem PC ist keine geeignete Anwendung zum Öffnen von Word-Dateien installiert." & vbCrLf
|
|
strMessage = strMessage & "Der Word Viewer wird benötigt, damit Sie QM-Dokumente aus einer Mitteilung öffnen können." & vbCrLf
|
|
strMessage = strMessage & "Bitte installieren Sie jetzt den Word-Viewer." & vbCrLf & vbCrLf
|
|
strMessage = strMessage & "Möchten Sie jetzt das Word-Viewer Setup starten ?"
|
|
If MsgBox(strMessage, vbOKCancel Or vbDefaultButton1, "Nachfrage zur Installation des Word Viewers") = vbOK Then
|
|
LogIntoDB "Wordviewer Setup gestartet", "AutoUpdate"
|
|
LRes = Shell("\\sla12file\Auftrag\Pruefstation 2000 EXE\Viewer\WDVIEWER.EXE", vbNormalFocus)
|
|
MsgBox "Weiter nach der Installation des Word-Viewers...", vbOKOnly, "Weiter ?"
|
|
End If
|
|
End If
|
|
Exit Sub
|
|
Errorhandler:
|
|
LogIntoDB "Fehler" & Err.Number & ":" & Err.Description & " in InstalliereErweiterungen().", "Fehler"
|
|
End Sub
|
|
|
|
|
|
|
|
|
|
Public Function Trefferquote(Optional AuftragNr As Variant, Optional PositionNr As Variant, Optional FromDate As Variant, Optional ToDate As Variant, Optional Typ As Variant, Optional Nennweite As Variant, Optional Temperatur As Variant, Optional Metrolog As Variant, Optional ByRef Progressbarcontrol As Object, Optional strWhere As String = "", Optional ByRef lngOutAnzahlGepruefterZaehler As Long, Optional ByRef lngOutAnzahlWiederholungen As Long) As Double
|
|
Dim strSQL As String
|
|
Dim rs As CRecordset
|
|
Dim AnzahlDatensaetze As Long
|
|
|
|
Dim AnzahlPruefungErfolgt As Long
|
|
Dim AnzahlWiederholungen As Long
|
|
Dim NrDatensatz As Long
|
|
|
|
On Error GoTo Errorhandler
|
|
|
|
strSQL = "SELECT AuftragPositionSerienNr.SerienNr ,AuftragPositionSerienNr.StatusFertigung, AuftragPositionSerienNr.AuftragNr, AuftragPositionSerienNr.PositionNr, AuftragPositionSerienNr.Wiederholungen, IdentNr.Typ, IdentNr.Nennweite, IdentNr.Temperatur FROM AuftragPositionSerienNr "
|
|
strSQL = strSQL & "INNER JOIN AlleAuftragPositionen ON (AlleAuftragPositionen.AuftragNr = AuftragPositionSerienNr.AuftragNr AND AlleAuftragPositionen.PositionNr = AuftragPositionSerienNr.PositionNr) "
|
|
strSQL = strSQL & "INNER JOIN Identnr ON (AlleAuftragPositionen.IdentNr = Identnr.IdentNr) "
|
|
|
|
If Not (IsMissing(AuftragNr) And CLng(AuftragNr) <> 0) Then
|
|
strSQL = strSQL & "WHERE 1=1 "
|
|
Else
|
|
strSQL = strSQL & "WHERE AlleAuftragPositionen.Herkunft <> 'AuftragPosition' "
|
|
End If
|
|
|
|
If Not IsMissing(AuftragNr) And CLng(AuftragNr) <> 0 Then
|
|
Debug.Print "AuftragNr=" & AuftragNr
|
|
strSQL = strSQL & "AND AuftragPositionSerienNr.AuftragNr=" & CLng(AuftragNr) & " "
|
|
End If
|
|
|
|
If Not IsMissing(PositionNr) And CLng(PositionNr) <> 0 Then
|
|
Debug.Print "PositionNr=" & PositionNr
|
|
strSQL = strSQL & "AND AuftragPositionSerienNr.PositionNr=" & CLng(PositionNr) & " "
|
|
End If
|
|
|
|
If Not IsMissing(FromDate) And CLng(FromDate) <> 0 Then
|
|
Debug.Print "FromDate=" & FromDate
|
|
strSQL = strSQL & "AND AuftragPositionSerienNr.PruefgangDatum >= CONVERT(DATETIME, '" & Format(FromDate, "yyyy-mm-dd") & "',121) "
|
|
End If
|
|
If Not IsMissing(ToDate) And CLng(ToDate) <> 0 Then
|
|
Debug.Print "ToDate=" & ToDate
|
|
strSQL = strSQL & "AND AuftragPositionSerienNr.PruefgangDatum <= CONVERT(DATETIME, '" & Format(ToDate, "yyyy-mm-dd") & " 23:59:59',121) "
|
|
End If
|
|
|
|
If Not IsMissing(Typ) And CStr(Typ) <> "" Then
|
|
Debug.Print "Typ=" & Typ
|
|
strSQL = strSQL & "AND IdentNr.Typ = '" & Typ & "' "
|
|
End If
|
|
|
|
If Not IsMissing(Nennweite) And CLng(Nennweite) <> 0 Then
|
|
Debug.Print "Nennweite=" & Nennweite
|
|
strSQL = strSQL & "AND IdentNr.Nennweite = " & Nennweite & " "
|
|
End If
|
|
|
|
If Not IsMissing(Temperatur) And CLng(Temperatur) <> 0 Then
|
|
Debug.Print "Temperatur=" & Temperatur
|
|
strSQL = strSQL & "AND IdentNr.Temperatur = " & Temperatur & " "
|
|
End If
|
|
|
|
If Not IsMissing(Metrolog) And CStr(Metrolog) <> "" Then
|
|
Debug.Print "Metrolog=" & Metrolog
|
|
strSQL = strSQL & "AND AuftragPositionSerienNr.Metrolog='" & Metrolog & "' "
|
|
End If
|
|
|
|
If strWhere <> "" Then
|
|
strSQL = strSQL & " AND " & strWhere
|
|
End If
|
|
|
|
Set rs = New CRecordset
|
|
|
|
Debug.Print strSQL
|
|
rs.openRS strSQL, True
|
|
|
|
AnzahlWiederholungen = 0
|
|
AnzahlPruefungErfolgt = 0
|
|
|
|
If Not rs.EOF Then
|
|
AnzahlDatensaetze = rs.RecordCount
|
|
|
|
If Not Progressbarcontrol Is Nothing Then
|
|
Progressbarcontrol.Max = AnzahlDatensaetze
|
|
End If
|
|
|
|
Do While Not rs.EOF
|
|
NrDatensatz = NrDatensatz + 1
|
|
Debug.Print rs.getLongValue("SerienNr") & " " & rs.getLongValue("Wiederholungen")
|
|
|
|
If rs.getLongValue("Wiederholungen") = 0 Then
|
|
AnzahlPruefungErfolgt = AnzahlPruefungErfolgt + 1
|
|
End If
|
|
If rs.getLongValue("Wiederholungen") > 0 Then
|
|
AnzahlWiederholungen = AnzahlWiederholungen + 1
|
|
End If
|
|
|
|
rs.MoveNext
|
|
|
|
If Not Progressbarcontrol Is Nothing Then
|
|
Progressbarcontrol.value = NrDatensatz
|
|
DoEvents
|
|
End If
|
|
Loop
|
|
|
|
If AnzahlWiederholungen + AnzahlPruefungErfolgt <> 0 Then
|
|
Trefferquote = Round(100 * AnzahlPruefungErfolgt / (AnzahlWiederholungen + AnzahlPruefungErfolgt), 2)
|
|
Else
|
|
Trefferquote = -1
|
|
End If
|
|
|
|
If Not IsMissing(lngOutAnzahlGepruefterZaehler) Then
|
|
lngOutAnzahlGepruefterZaehler = AnzahlPruefungErfolgt
|
|
End If
|
|
|
|
If Not IsMissing(lngOutAnzahlWiederholungen) Then
|
|
lngOutAnzahlWiederholungen = AnzahlWiederholungen
|
|
End If
|
|
Else
|
|
Trefferquote = -1
|
|
End If
|
|
If Not Progressbarcontrol Is Nothing Then
|
|
Progressbarcontrol.value = 0
|
|
End If
|
|
Exit Function
|
|
Errorhandler:
|
|
Trefferquote = -1
|
|
End Function
|
|
|
|
|
|
Public Function Hex2Long(strHex As String) As Long
|
|
On Error GoTo Errorhandler
|
|
Hex2Long = 0
|
|
strHex = Trim$(strHex)
|
|
If strHex = "" Then Exit Function
|
|
Hex2Long = CLng("&H0000" & strHex)
|
|
Exit Function
|
|
Errorhandler:
|
|
DebugMsg "Hex decodierung nicht möglich für '" & strHex & "' "
|
|
LogIntoDB "Hex decodierung nicht möglich für '" & strHex & "' ", "Umwandlung"
|
|
End Function
|
|
|
|
|
|
Public Function GetMyFileDateTimeString() As String
|
|
Dim strPath As String
|
|
|
|
strPath = App.Path & "\" & App.EXEName & ".exe"
|
|
|
|
If Dir(strPath) = App.EXEName & ".exe" Then
|
|
GetMyFileDateTimeString = FileDateTime(strPath)
|
|
Else
|
|
GetMyFileDateTimeString = ""
|
|
End If
|
|
End Function
|
|
|
|
'Public Function FileDoesExists(strPath As String) As Boolean
|
|
' Dim fso As FileSystemObject
|
|
' Set fso = New FileSystemObject
|
|
' FileDoesExists = fso.FileExists(strPath)
|
|
'End Function
|
|
|
|
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
|
|
' alte Logdateien archivieren
|
|
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
|
|
Public Sub LogDateienverschieben()
|
|
Dim strFile As String
|
|
Dim strNewFile As String
|
|
Dim i As Integer
|
|
|
|
On Error Resume Next
|
|
|
|
strFile = Dir("C:\P*.log")
|
|
Do While strFile <> ""
|
|
If InStr(LogFilePath, strFile) = 0 Then
|
|
' alte Bakups verschieben
|
|
strNewFile = "\\sla12file\Auftrag\PruefstationLogdateien\" & strFile
|
|
|
|
Name "C:\" & strFile As strNewFile
|
|
|
|
|
|
If Err.Number = 58 Then
|
|
' Ziel Datei existiert bereits
|
|
Do
|
|
' alternativen Namen suchen
|
|
Err.Clear
|
|
i = i + 1
|
|
strNewFile = Replace(strFile, ".log", "_" & i & ".log")
|
|
' versuchen
|
|
Debug.Print "verschiebe " & strFile & " nach " & strNewFile & "..."
|
|
Name "C:\" & strFile As "\\sla12file\Auftrag\PruefstationLogdateien\" & strNewFile
|
|
If i > 100 Then Exit Do
|
|
Loop While Err.Number = 58
|
|
' kein "Datei existiert bereits" Fehler
|
|
If Err.Number = 0 Then
|
|
WriteToLog "Logdatei verschoben: " & strFile & " umbenannt in " & strNewFile & " und verschoben."
|
|
Else
|
|
WriteToLog "Logdatei konnte nicht verschoben werden: " & strFile & ". " & Err.Description
|
|
End If
|
|
ElseIf Err.Number = 0 Then
|
|
WriteToLog "Logdatei verschoben: " & "\\sla12file\Auftrag\PruefstationLogdateien\" & strFile
|
|
Else
|
|
WriteToLog "Logdatei " & strFile & " konnte nicht verschoben werden."
|
|
End If
|
|
Else
|
|
Debug.Print "aktuelle Log-Datei " & strFile & " nicht verschieben"
|
|
End If
|
|
strFile = Dir()
|
|
Loop
|
|
If Err Then
|
|
DebugMsg "Fehler beim verschieben der Logdateien: " & Err.Description
|
|
End If
|
|
End Sub
|
|
|
|
|
|
Public Function CheckAndCreateInSpeicherabbild(ByVal EinbauplatzNr As Integer, ByVal FabNr As Long) As Boolean
|
|
Dim rs As CRecordset
|
|
On Error GoTo CheckAndCreateInSpeicherabbildError
|
|
|
|
TryAgain:
|
|
Set rs = New CRecordset
|
|
|
|
rs.openRS "SELECT * from Speicherabbild where FabNr = " & FabNr
|
|
If rs.EOF Then
|
|
rs.addNew
|
|
Call rs.setValue("FabNr", FabNr)
|
|
Call rs.setValue("Datum", Now())
|
|
Call rs.setValue("MemoryContent", "")
|
|
|
|
If Not rs.update Then
|
|
GoTo CheckAndCreateInSpeicherabbildError
|
|
End If
|
|
|
|
Debug.Print "Datensatz mit der FabFabNr " & FabNr & " in der Tabelle Speicherabbild erzeugt."
|
|
Else
|
|
Debug.Print "Datensatz mit der FabFabNr " & FabNr & " ist in der Tabelle Speicherabbild vorhanden."
|
|
End If
|
|
Set rs = Nothing
|
|
CheckAndCreateInSpeicherabbild = True
|
|
Exit Function
|
|
|
|
CheckAndCreateInSpeicherabbildError:
|
|
Debug.Print "CheckAndCreateInSpeicherabbild: " & Err.Description
|
|
If MsgBox("FabNr '" & FabNr & "' konnte nicht in Tabelle Speicherabbild erzeugt werden. Fehler " & Err.Number & vbCrLf & Err.Description, vbRetryCancel Or vbDefaultButton1) = vbRetry Then
|
|
Set rs = Nothing
|
|
Resume TryAgain
|
|
Else
|
|
Set rs = Nothing
|
|
Debug.Print "CheckAndCreateInSpeicherabbild abgebrochen."
|
|
CheckAndCreateInSpeicherabbild = False
|
|
End If
|
|
End Function
|
|
|
|
|
|
Public Sub SchreibeZulassungspruefdaten(ByVal lngSerienNr As Long, ByVal lngPruefgangNr As Long, dblSollDurchfluss As Double, Optional dblActualflowrate As Double, Optional dblIndicatedvolume As Double, Optional dblActualvolume As Double, Optional dblMeterError As Double, Optional dblWatertemp As Double, Optional dtTimestamp As Date, Optional blnPruefartWaage As Boolean)
|
|
On Error GoTo Errorhandler
|
|
'''''''''''''''''''''''''''
|
|
'''' Schlüsselfelder'''''''
|
|
'''''''''''''''''''''''''''
|
|
' SerienNr
|
|
' PruefgangNr
|
|
' SollDurchfluss
|
|
'''''''''''''''''''''''''''
|
|
'''''Datenfelder'''''''''''
|
|
'''''''''''''''''''''''''''
|
|
' Actualflowrate
|
|
' Indicatedvolume
|
|
' Actualvolume
|
|
'
|
|
'
|
|
' als Endmarke (am Ende einer Prüfung) werden diese Werte mit 0 noch einmal gespeichert
|
|
'''''''''''''''''''''''''''
|
|
'''''''''''''''''''''''''''
|
|
Dim strSQL As String
|
|
Dim rs As CRecordset
|
|
|
|
WriteToLog "speichern der Zulassungspruefdaten"
|
|
|
|
dblSollDurchfluss = Round(dblSollDurchfluss, 3)
|
|
|
|
strSQL = "SELECT * from Zulassungspruefdaten where SerienNr = " & lngSerienNr
|
|
strSQL = strSQL + " and PruefgangNr=" & lngPruefgangNr
|
|
strSQL = strSQL + " and SollDurchfluss=" & Replace(dblSollDurchfluss, ",", ".")
|
|
|
|
Set rs = New CRecordset
|
|
|
|
rs.openRS strSQL, False
|
|
If rs.EOF Then
|
|
rs.addNew
|
|
Call rs.setValue("SerienNr", lngSerienNr)
|
|
Call rs.setValue("PruefgangNr", lngPruefgangNr)
|
|
Call rs.setValue("SollDurchfluss", dblSollDurchfluss)
|
|
End If
|
|
|
|
If Not IsMissing(dblActualflowrate) Then
|
|
Call rs.setValue("Actualflowrate", dblActualflowrate)
|
|
End If
|
|
|
|
If Not IsMissing(dblIndicatedvolume) Then
|
|
Call rs.setValue("Indicatedvolume", dblIndicatedvolume)
|
|
End If
|
|
|
|
If Not IsMissing(dblActualvolume) Then
|
|
Call rs.setValue("Actualvolume", dblActualvolume)
|
|
End If
|
|
|
|
If Not IsMissing(dblWatertemp) Then
|
|
Call rs.setValue("Watertemp", dblWatertemp)
|
|
End If
|
|
|
|
If Not IsMissing(dblMeterError) Then
|
|
Call rs.setValue("MeterError", dblMeterError)
|
|
End If
|
|
|
|
If Not IsMissing(dtTimestamp) Then
|
|
Call rs.setValue("AnlageDatum", dtTimestamp)
|
|
End If
|
|
|
|
If Not IsMissing(blnPruefartWaage) Then
|
|
Call rs.setValue("PruefartWaage", blnPruefartWaage)
|
|
End If
|
|
|
|
Dim strTemp As String
|
|
|
|
Call MesseWetterdaten
|
|
If g_dblLuftTemperatur <> 0 Then
|
|
Call rs.setValue("LuftTemp", Round(g_dblLuftTemperatur, 1))
|
|
End If
|
|
If g_dblLuftFeuchte <> 0 Then
|
|
Call rs.setValue("Luftfeuchte", Round(g_dblLuftFeuchte, 1))
|
|
End If
|
|
If g_dblLuftDruck <> 0 Then
|
|
Call rs.setValue("Luftdruck", Round(g_dblLuftDruck, 1))
|
|
End If
|
|
|
|
If g_dblWasserdruck = 0 Then
|
|
g_dblWasserdruck = Round(MesseWasserdruck(), 3)
|
|
End If
|
|
|
|
' gespeicherten Wasserdruck
|
|
If g_dblWasserdruck <> -1 Then
|
|
Call rs.setValue("InitialSupplyPressure", g_dblWasserdruck)
|
|
End If
|
|
|
|
rs.update
|
|
Exit Sub
|
|
Errorhandler:
|
|
LogIntoDB "Fehler " & Err.Number & " in SchreibeZulassungspruefdaten(): " & Err.Description, "Softwarefehler"
|
|
Exit Sub
|
|
Resume
|
|
|
|
End Sub
|
|
|
|
|
|
Public Function GetWasserdruck(ByVal ID As Integer, ByVal Channel As Integer, ByVal dblFaktor As Double, dblWasserdruck As Double) As Boolean
|
|
On Error GoTo Errorhandler
|
|
Dim objLabjack As Object
|
|
Dim sngWert As Single
|
|
Dim lngReturn As Long
|
|
|
|
GetWasserdruck = False
|
|
|
|
Set objLabjack = CreateObject("LabjackWrapper.MainClass")
|
|
lngReturn = objLabjack.GetAnalogwert(ID, Channel, sngWert)
|
|
If lngReturn = 0 Then
|
|
dblWasserdruck = CDbl(sngWert) * dblFaktor
|
|
'WriteToLog "Wasserdruck messen: Spannung (" & sngWert & " V) * Faktor (" & dblFaktor & ") = " & dblWasserdruck
|
|
GetWasserdruck = True
|
|
Else
|
|
'LogIntoDB "Fehler in GetWasserdruck GetAnalogwert(): " & objLabjack.GetLjackError(lngReturn)
|
|
End If
|
|
Exit Function
|
|
Errorhandler:
|
|
LogIntoDB "Fehler " & Err.Number & " in GetWasserdruck(" & ID & "," & Channel & "): " & Err.Description, "Labjack"
|
|
End Function
|
|
|
|
|
|
Public Function MesseWasserdruck() As Double
|
|
On Error GoTo Errorhandler
|
|
|
|
Dim LabjackID As Integer
|
|
Dim LabjackChannel As Integer
|
|
Dim dblFaktor As Double
|
|
Dim dblWasserdruck As Double
|
|
|
|
MesseWasserdruck = -1
|
|
If g_App.Settings.GetWasserdruckLabjackSettings(LabjackID, LabjackChannel, dblFaktor) = True Then
|
|
If GetWasserdruck(LabjackID, LabjackChannel, dblFaktor, dblWasserdruck) Then
|
|
MesseWasserdruck = dblWasserdruck
|
|
End If
|
|
End If
|
|
Exit Function
|
|
Errorhandler:
|
|
LogIntoDB "Fehler " & Err.Number & " in MesseWasserdruck(): " & Err.Description, "Softwarefehler"
|
|
End Function
|
|
|
|
|
|
Public Function MesseWetterdaten() As Boolean
|
|
On Error GoTo Errorhandler
|
|
|
|
Dim strTemp As String
|
|
Dim SPS As CSPS
|
|
|
|
|
|
If g_App.Settings.GetWetterstationURL <> "" Then
|
|
' falls Wetterstation URL vorhanden ist auf jeden Fall damit den Luftdruck holen, weil dieser im ganzen Haus gleich ist
|
|
' ebenfalls Temp und Feuchte aus der Wetterstation holen
|
|
If GetWeatherData(g_dblLuftTemperatur, g_dblLuftFeuchte, g_dblLuftDruck, strTemp) = False Then
|
|
WriteToLog "Wetterstation (" & g_App.Settings.GetWetterstationURL & ") gibt Fehler zurück: " & strTemp
|
|
LogIntoDB strTemp, "Wetterstation"
|
|
' Es gab einen Fehler
|
|
Else
|
|
MesseWetterdaten = True
|
|
End If
|
|
End If
|
|
|
|
If g_App.Settings.getTempFeuchteMessen = 1 Then
|
|
'Temp und Feuchte aus der SPS holen, ggf überschreiben
|
|
Set SPS = g_App.getSPS
|
|
If Not SPS Is Nothing Then
|
|
g_dblLuftTemperatur = SPS.GetLuftTemperatur
|
|
g_dblLuftFeuchte = SPS.GetRelativeFeuchte
|
|
MesseWetterdaten = True
|
|
End If
|
|
End If
|
|
|
|
If g_App.Settings.getTempFeuchteMessen = -1 Then
|
|
g_dblLuftTemperatur = 0
|
|
g_dblLuftFeuchte = 0
|
|
End If
|
|
|
|
Exit Function
|
|
Errorhandler:
|
|
LogIntoDB "MesseWetterdaten: " & Err.Number & ": " & Err.Description, "Softwarefehler"
|
|
End Function
|
|
|
|
|
|
Public Function GetLetzteAenderungSollwertFromMetrologIdentNr(ByVal strMetrolog As String, lngIdentNr As Long, ByRef dblOutSollwert As Double, ByRef strOutPruefername As String, ByRef dateOutDatum As Date, ByRef strOutBemerkung As String) As Boolean
|
|
Dim strSQL As String
|
|
Dim rs As CRecordset
|
|
Dim Mitarbeiter As CMitarbeiter
|
|
Dim lngGruppe As Long
|
|
|
|
lngGruppe = GetIdentNrGruppe(lngIdentNr)
|
|
If lngGruppe = -1 Then
|
|
GetLetzteAenderungSollwertFromMetrologIdentNr = False
|
|
Exit Function
|
|
End If
|
|
|
|
Set rs = New CRecordset
|
|
strSQL = "SELECT * FROM SollwertAenderungen WHERE (Metrolog = '" & strMetrolog & "') AND (IdentNrGruppe = " & lngGruppe & ") order by Datum desc"
|
|
rs.openRS strSQL, True
|
|
Debug.Print strSQL
|
|
|
|
If Not rs.EOF Then
|
|
GetLetzteAenderungSollwertFromMetrologIdentNr = True
|
|
dblOutSollwert = Round(rs.getDoubleValue("Sollwert"), 1)
|
|
strOutBemerkung = rs.getStringValue("Bemerkung")
|
|
|
|
'----
|
|
Set Mitarbeiter = New CMitarbeiter
|
|
Mitarbeiter.loadForNr rs.getLongValue("Pruefer")
|
|
strOutPruefername = Mitarbeiter.getAnfangsbuchstabeVornameundName
|
|
Set Mitarbeiter = Nothing
|
|
'----
|
|
dateOutDatum = rs.getDateValue("Datum")
|
|
End If
|
|
End Function
|
|
|
|
Public Function GetIdentNrGruppe(lngIdentNr As Long) As Long
|
|
Dim strSQL As String
|
|
Dim rs As CRecordset
|
|
strSQL = "SELECT GruppenID FROM IdentNrGruppierung WHERE IdentNr=" & lngIdentNr
|
|
Set rs = New CRecordset
|
|
rs.openRS strSQL, True
|
|
If Not rs.EOF Then
|
|
GetIdentNrGruppe = rs.getLongValue("GruppenID")
|
|
Else
|
|
GetIdentNrGruppe = -1
|
|
LogIntoDB "Keine Gruppierung für IdentNr " & lngIdentNr, "IdentNr-Gruppierung"
|
|
End If
|
|
Exit Function
|
|
Errorhandler:
|
|
LogIntoDB "Fehler " & Err.Number & " in GetIdentNrGruppe(" & lngIdentNr & "): " & Err.Description, "Softwarefehler"
|
|
End Function
|
|
|
|
Public Function GetWeatherData(ByRef dblLT As Double, ByRef dblRF As Double, ByRef dblLD As Double, ByRef strFehler As String) As Boolean
|
|
On Error GoTo Errorhandler
|
|
Dim strURL As String
|
|
Dim objForm As frmWetterstation
|
|
Dim lngMousepointer As Long
|
|
|
|
lngMousepointer = Screen.MousePointer
|
|
|
|
Screen.MousePointer = vbHourglass
|
|
strURL = g_App.Settings.GetWetterstationURL()
|
|
If strURL <> "" Then
|
|
Set objForm = New frmWetterstation
|
|
strFehler = ""
|
|
If objForm.HoleWetterdaten(strURL, dblLT, dblRF, dblLD, 20) = False Then
|
|
strFehler = objForm.GetError
|
|
GetWeatherData = False
|
|
|
|
|
|
Else
|
|
GetWeatherData = True
|
|
End If
|
|
End If
|
|
|
|
Screen.MousePointer = lngMousepointer
|
|
Exit Function
|
|
Errorhandler:
|
|
Screen.MousePointer = lngMousepointer
|
|
LogIntoDB "Fehler " & Err.Number & " in GetWeatherData: " & Err.Description, "Softwarefehler"
|
|
End Function
|
|
|
|
|
|
Private Sub SaveIniDateiToDB()
|
|
Dim sSectionNames As String
|
|
Dim sKeyNames As String
|
|
Dim arkey() As String
|
|
Dim strKey As String
|
|
Dim strSection As String
|
|
Dim Section() As String
|
|
Dim strValue As String
|
|
Dim i As Integer
|
|
Dim j As Integer
|
|
|
|
|
|
Dim strSQL As String
|
|
Dim rs As CRecordset
|
|
strSQL = "SELECT * from _ini_datei where Pruefstation = " & g_App.PruefstationNr & " and hostname = '" & g_strHostname & "'"
|
|
Set rs = New CRecordset
|
|
rs.openRS strSQL, True
|
|
|
|
If Not rs.EOF Then
|
|
Exit Sub
|
|
End If
|
|
|
|
|
|
sSectionNames = g_App.Settings.GetOrSetIniWert(vbNullString, "", "")
|
|
Section = Split(sSectionNames, vbNullChar)
|
|
|
|
For i = 0 To UBound(Section) - 1
|
|
strSection = Section(i)
|
|
Debug.Print "[" & strSection & "]"
|
|
sKeyNames = g_App.Settings.GetOrSetIniWert(Section(i), vbNullString, "")
|
|
arkey = Split(sKeyNames, vbNullChar)
|
|
|
|
For j = 0 To UBound(arkey) - 1
|
|
strKey = arkey(j)
|
|
strValue = g_App.Settings.GetOrSetIniWert(Section(i), strKey, "")
|
|
|
|
WriteIniToDB strSection, strKey, strValue
|
|
Next j
|
|
Next i
|
|
Exit Sub
|
|
Errorhandler:
|
|
LogIntoDB "Fehler " & Err.Number & "in SaveIniDateiToDB(): " & Err.Description, "Softwarefehler"
|
|
End Sub
|
|
|
|
Private Sub WriteIniToDB(strSection As String, strKey As String, strValue As String)
|
|
Dim strSQL As String
|
|
Dim rs As CRecordset
|
|
|
|
strSQL = "SELECT * from _ini_datei where Pruefstation = " & g_App.PruefstationNr
|
|
strSQL = strSQL & " AND ini_Section = '" & Replace(strSection, "'", "''") & "'"
|
|
strSQL = strSQL & " AND ini_key = '" & Replace(strKey, "'", "''") & "'"
|
|
strSQL = strSQL & " AND hostname = '" & g_strHostname & "'"
|
|
|
|
|
|
Set rs = New CRecordset
|
|
rs.openRS strSQL, False
|
|
If rs.EOF Then
|
|
rs.addNew
|
|
rs.setValue "Pruefstation", g_App.PruefstationNr
|
|
rs.setValue "ini_Section", strSection
|
|
rs.setValue "ini_key", strKey
|
|
rs.setValue "Wert", strValue
|
|
rs.setValue "hostname", g_strHostname
|
|
End If
|
|
rs.update
|
|
Set rs = Nothing
|
|
End Sub
|
|
|
|
|
|
Public Function getDBName() As String
|
|
On Error GoTo Errorhandler
|
|
Dim lngPos As Long
|
|
Dim strTemp As String
|
|
strTemp = g_App.getDB.getConnection.ConnectionString
|
|
lngPos = InStr(1, LCase(strTemp), LCase("DATABASE="))
|
|
getDBName = Mid(strTemp, lngPos + 9)
|
|
lngPos = InStr(1, getDBName, ";")
|
|
If lngPos = 0 Then
|
|
lngPos = InStr(1, getDBName, """")
|
|
End If
|
|
If lngPos > 0 Then
|
|
getDBName = Mid(getDBName, 1, lngPos - 1)
|
|
End If
|
|
|
|
Errorhandler:
|
|
End Function
|
|
|
|
|
|
|
|
Public Function EinesDerWoerterVorhanden(strText As String, strWortListe As String, ByRef gefundenesWort As String) As Boolean
|
|
Dim varWort As Variant
|
|
|
|
For Each varWort In Split(strWortListe, "|")
|
|
If InStr(LCase(strText), LCase(varWort)) > 0 Then
|
|
EinesDerWoerterVorhanden = True
|
|
gefundenesWort = gefundenesWort & ", '" & CStr(varWort) & "'"
|
|
End If
|
|
Next
|
|
|
|
End Function
|
|
|
|
|
|
|
|
|
|
Public Sub BenachrichtigeDatenpflege(strText As String)
|
|
If g_blnVersuch Then Exit Sub
|
|
WriteToLog strText
|
|
|
|
If MsgBox("Möchten Sie eine Benachrichtigung an Andreas Beyer zur Datenpflege senden? " & strText, vbYesNo Or vbDefaultButton2) = vbYes Then
|
|
Call SendMail("nobody@sensus.com", "Andreas.Beyer@sensus.com;reinhard.henning@sensus.com", "Datenpflege erforderlich", strText)
|
|
End If
|
|
End Sub
|
|
|
|
|
|
Public Function GetWertFromZusatztext(strZusatztext As String, strName As String) As String
|
|
Dim varZeile As Variant
|
|
Dim lngPosition As Long
|
|
|
|
For Each varZeile In Split(strZusatztext, vbCrLf)
|
|
If Left(varZeile, Len(strName)) = strName Then
|
|
lngPosition = InStr(1, varZeile, ":")
|
|
If lngPosition > 0 Then
|
|
GetWertFromZusatztext = Trim(Mid(varZeile, lngPosition + 1))
|
|
Else
|
|
GetWertFromZusatztext = Trim(Mid(varZeile, Len(strName) + 1))
|
|
End If
|
|
Exit For
|
|
End If
|
|
Next
|
|
End Function
|
|
|
|
Public Sub SavePrueffehlerInfo(ByVal PruefgangNr As Long, ByVal SerienNr As Long, ByVal strText As String)
|
|
If PruefgangNr = 0 Then Exit Sub
|
|
|
|
On Error GoTo Errorhanldler
|
|
Dim rs As CRecordset
|
|
Dim strSQL As String
|
|
strSQL = "SELECT * from Prueffehler where SerienNr = " & SerienNr & " and PruefgangNr = " & PruefgangNr
|
|
Set rs = New CRecordset
|
|
rs.openRS strSQL, False
|
|
If rs.EOF Then
|
|
rs.addNew
|
|
rs.setValue "SerienNr", SerienNr
|
|
rs.setValue "PruefgangNr", PruefgangNr
|
|
End If
|
|
|
|
rs.setValue "Info", strText
|
|
|
|
rs.update
|
|
Exit Sub
|
|
Errorhanldler:
|
|
LogIntoDB "Fehler " & Err.Number & " in SavePrueffehlerInfo(): " & Err.Description, "Softwarefehler"
|
|
End Sub
|
|
|
|
Public Sub LoadPrueffehlerInfo(ByVal PruefgangNr As Long, ByVal SerienNr As Long, ByRef strText As String)
|
|
On Error GoTo Errorhanldler
|
|
|
|
Dim rs As CRecordset
|
|
Dim strSQL As String
|
|
strSQL = "SELECT * from Prueffehler where SerienNr = " & SerienNr & " and PruefgangNr = " & PruefgangNr
|
|
Set rs = New CRecordset
|
|
rs.openRS strSQL, True
|
|
If Not rs.EOF Then
|
|
strText = rs.getStringValue("Info")
|
|
Else
|
|
strText = ""
|
|
End If
|
|
Exit Sub
|
|
Errorhanldler:
|
|
LogIntoDB "Fehler " & Err.Number & " in LoadPrueffehlerInfo(): " & Err.Description, "Softwarefehler"
|
|
End Sub
|
|
|
|
|
|
Public Sub Pruefpunktkontrolle(ColEinbauplatz As Collection, colUniquePP As CPruefpunktCol)
|
|
Dim objForm As frmFlexgrid
|
|
Dim Einbauplatz As CEinbauplatz
|
|
Dim Pruefzaehler As CPruefzaehler
|
|
Dim PruefpunktCol As Collection
|
|
Dim Pruefpunkt As CPruefpunkt
|
|
Dim PPNr As Integer
|
|
|
|
|
|
Set objForm = New frmFlexgrid
|
|
objForm.MSFlexGrid1.Clear
|
|
|
|
objForm.caption = "Pruef2000 Prüfpunkt Kontrolle"
|
|
objForm.lblText = "Prüfpunkt Kontrolle"
|
|
objForm.MSFlexGrid1.Cols = 11
|
|
objForm.MSFlexGrid1.Rows = 11
|
|
objForm.Width = 6960
|
|
objForm.chkIgnore.Visible = False
|
|
|
|
' Für alle Einbauplätze
|
|
For Each Einbauplatz In ColEinbauplatz
|
|
Set Pruefzaehler = Einbauplatz.getPruefzaehler
|
|
If Not Pruefzaehler Is Nothing Then
|
|
' für jeden Prüfzähler
|
|
objForm.MSFlexGrid1.TextMatrix(Einbauplatz.getNr, 0) = " " & Pruefzaehler.getSerienNr & " "
|
|
|
|
PPNr = 0
|
|
For Each Pruefpunkt In colUniquePP.getCollection
|
|
PPNr = PPNr + 1
|
|
If objForm.MSFlexGrid1.TextMatrix(0, PPNr) = "" Then
|
|
objForm.MSFlexGrid1.TextMatrix(0, PPNr) = Pruefpunkt.getQ
|
|
Else
|
|
If Not objForm.MSFlexGrid1.TextMatrix(0, PPNr) = Pruefpunkt.getQ Then
|
|
Debug.Print objForm.MSFlexGrid1.TextMatrix(0, PPNr) & " <> " & Pruefpunkt.getQ
|
|
End If
|
|
End If
|
|
|
|
objForm.MSFlexGrid1.row = Einbauplatz.getNr
|
|
objForm.MSFlexGrid1.col = PPNr
|
|
|
|
If Pruefzaehler.getPruefpunkte.hasQ(Pruefpunkt.getQ) Then
|
|
objForm.MSFlexGrid1.CellBackColor = vbGreen
|
|
Else
|
|
objForm.MSFlexGrid1.CellBackColor = vbRed
|
|
End If
|
|
Next
|
|
End If
|
|
Next
|
|
objForm.Show vbModal
|
|
End Sub
|
|
|
|
|
|
|
|
Public Sub WriteToFW2Logfile(Einbauplatz As CEinbauplatz, strText As String, Optional blnZeilenumbruch As Boolean = True)
|
|
Dim fso As scripting.FileSystemObject
|
|
Dim ts As TextStream
|
|
Dim strDir As String
|
|
Dim strFilepath As String
|
|
|
|
On Error GoTo Errorhandler
|
|
|
|
Set fso = New scripting.FileSystemObject
|
|
|
|
WriteToLog "#" & Einbauplatz.getNr & ": " & strText
|
|
|
|
If Einbauplatz.m_strFW2LogFile = "" Then
|
|
Exit Sub
|
|
Else
|
|
|
|
Set ts = fso.OpenTextFile(Einbauplatz.m_strFW2LogFile, ForAppending, True)
|
|
Debug.Print strText
|
|
|
|
If blnZeilenumbruch Then
|
|
ts.Write Format(Now, "yyyy-mm-dd hh:mm:ss") & vbTab & strText & vbCrLf
|
|
Else
|
|
ts.Write Format(Now, "yyyy-mm-dd hh:mm:ss") & vbTab & strText
|
|
End If
|
|
ts.Close
|
|
End If
|
|
Exit Sub
|
|
Errorhandler:
|
|
WriteToLog "Log Err: '" & Err.Description & "' für EBP-" & Einbauplatz.getNr & ": " & strText
|
|
If Not ts Is Nothing Then ts.Close
|
|
End Sub
|
|
|
|
|
|
'Public Sub UpdateSchlossAusLog()
|
|
'On Error GoTo Errorhandler
|
|
'
|
|
' Dim strSQL As String
|
|
' Dim rs As CRecordset
|
|
' Dim lngSerienNr As Long
|
|
'
|
|
' strSQL = "SELECT * from [PruefstationLog] where Text like 'Schloss wurde geschlossen für%'"
|
|
'
|
|
' Set rs = New CRecordset
|
|
' rs.openRS strSQL, True
|
|
'
|
|
' Do While Not rs.EOF
|
|
' lngSerienNr = Val(Replace(rs.getStringValue("Text"), "Schloss wurde geschlossen für", ""))
|
|
' Datenbank_Vermerk_Schloss lngSerienNr, False
|
|
' rs.MoveNext
|
|
' Loop
|
|
' Exit Sub
|
|
'Errorhandler:
|
|
' LogIntoDB "Fehler " & Err.Number & " in UpdateSchlossAusLog :" & Err.Description, "Softwarefehler"
|
|
'End Sub
|
|
|
|
|
|
'Public Sub Datenbank_Vermerk_Schloss(lngSerienNr As Long, blnGeschlossen, lngFabNr As Long)
|
|
'On Error GoTo Errorhandler
|
|
' Dim strSQL As String
|
|
' Dim rs As CRecordset
|
|
'
|
|
' strSQL = "SELECT * from Seriennummer where SerienNr = " & lngSerienNr
|
|
' Set rs = New CRecordset
|
|
'
|
|
' rs.openRS strSQL, False
|
|
' If rs.EOF Then
|
|
' rs.addNew
|
|
' rs.setValue "SerienNr", lngSerienNr
|
|
' End If
|
|
' rs.setValue "Schloss_geschlossen", blnGeschlossen
|
|
' rs.update
|
|
' Exit Sub
|
|
'Errorhandler:
|
|
' LogIntoDB "Fehler " & Err.Number & " in Datenbank_Vermerk_Schloss(" & lngSerienNr & ") :" & Err.Description, "Softwarefehler"
|
|
'End Sub
|
|
|
|
'Public Function IstSchlossGeschlossen(lngSerienNr As Long) As Boolean
|
|
'On Error GoTo Errorhandler
|
|
' Dim strSQL As String
|
|
' Dim rs As CRecordset
|
|
'
|
|
' strSQL = "SELECT * from Seriennummer where SerienNr = " & lngSerienNr
|
|
' Set rs = New CRecordset
|
|
' rs.openRS strSQL, False
|
|
' If Not rs.EOF Then
|
|
' IstSchlossGeschlossen = rs.getBooleanValue("Schloss_geschlossen")
|
|
' Exit Function
|
|
' End If
|
|
' IstSchlossGeschlossen = False
|
|
' Exit Function
|
|
'Errorhandler:
|
|
' LogIntoDB "Fehler " & Err.Number & " in IstSchlossGeschlossen(" & lngSerienNr & ") :" & Err.Description, "Softwarefehler"
|
|
'End Function
|
|
|
|
|
|
|
|
|
|
Public Sub PrintGrid(Grid As MSFlexGrid, ByVal LeftMargin As Single, _
|
|
ByVal TopMargin As Single, ByVal RightMargin As _
|
|
Single, ByVal BottomMargin As Single, Titel As _
|
|
String, Datum As String, Optional many As Integer)
|
|
|
|
Dim tRange As TFormatRange
|
|
Dim lReturn As Long
|
|
Dim DName As String
|
|
Dim DSchacht As Integer
|
|
Dim gbeg As Long
|
|
Dim CopyCW() As Long
|
|
Dim GRef As Boolean
|
|
Dim x%
|
|
Dim varTemp As Variant
|
|
Dim intSeite As Integer
|
|
|
|
intSeite = 0
|
|
|
|
GRef = False
|
|
If many > 0 Then
|
|
' Anzahl der zu druckenden Colums festlegen
|
|
' Alles > many wird auf colwidth = 0 gesetzt
|
|
If Grid.Cols > many Then
|
|
gbeg = Grid.Cols - many
|
|
ReDim CopyCW(gbeg)
|
|
Grid.Redraw = False
|
|
For x = many To Grid.Cols - 1
|
|
CopyCW(x - many) = Grid.ColWidth(x)
|
|
Grid.ColWidth(x) = 0
|
|
Next x
|
|
GRef = True
|
|
End If
|
|
End If
|
|
|
|
'mit wParam <> 0 kann überprüft werden
|
|
'ob das Control OPP unterstützt, wenn ja wird
|
|
'456654 (VP_YESIDO) zurückgeliefert
|
|
lReturn = SendMessage(Grid.hwnd, VP_FORMATRANGE, 1, 0)
|
|
|
|
If lReturn = VP_YESIDO Then
|
|
|
|
'Struktur mit Formatierungsinformationen füllen
|
|
Printer.ScaleMode = vbPixels
|
|
|
|
With tRange
|
|
.hdc = Printer.hdc
|
|
|
|
'Höhe und Breite einer Seite (in Pixel)
|
|
.rcPage.rRight = Printer.ScaleWidth
|
|
.rcPage.rBottom = Printer.ScaleHeight
|
|
|
|
'Lage und Abmessungen des Bereichs auf den
|
|
'gedruckt werden soll (in Pixel)
|
|
.rc.rLeft = Printer.ScaleX(LeftMargin, vbMillimeters)
|
|
.rc.rTop = Printer.ScaleY(TopMargin, vbMillimeters)
|
|
.rc.rRight = .rcPage.rRight - Printer.ScaleX(RightMargin, _
|
|
vbMillimeters)
|
|
|
|
.rc.rBottom = .rcPage.rBottom - Printer.ScaleY(BottomMargin, _
|
|
vbMillimeters)
|
|
End With
|
|
|
|
'Drucker initialisieren
|
|
Printer.Print vbNullString
|
|
|
|
intSeite = 0
|
|
'Seite(n) drucken
|
|
Do
|
|
Printer.CurrentY = Printer.ScaleY(10, vbMillimeters)
|
|
intSeite = intSeite + 1
|
|
|
|
If intSeite = 1 Then
|
|
If Titel <> "" Then
|
|
Printer.Font = "Arial"
|
|
Printer.Font = 14
|
|
Printer.FontBold = True
|
|
|
|
For Each varTemp In Split(Titel, vbCrLf)
|
|
Printer.CurrentX = Printer.ScaleX(LeftMargin, vbMillimeters)
|
|
Printer.Print varTemp
|
|
Next
|
|
End If
|
|
|
|
Printer.CurrentX = Printer.ScaleX(LeftMargin, vbMillimeters)
|
|
Printer.Print "Ausdruck vom " & Format(Now, "dd.mm.yyyy hh:mm") & ", Seite " & intSeite
|
|
End If
|
|
Printer.CurrentX = Printer.ScaleX(LeftMargin, vbMillimeters)
|
|
'Printer.CurrentY = Printer.ScaleY(16, vbMillimeters)
|
|
lReturn = SendMessage(Grid.hwnd, VP_FORMATRANGE, 0, _
|
|
VarPtr(tRange))
|
|
|
|
If lReturn < 0 Then
|
|
Exit Do
|
|
Else
|
|
Printer.NewPage
|
|
End If
|
|
Loop
|
|
|
|
'Reset
|
|
lReturn = SendMessage(Grid.hwnd, VP_FORMATRANGE, 0, 0)
|
|
End If
|
|
|
|
If GRef Then
|
|
'Alle Colums wieder in richtiger Breite darstellen
|
|
For x = many To Grid.Cols - 1
|
|
Grid.ColWidth(x) = CopyCW(x - many)
|
|
Next x
|
|
Grid.Redraw = True
|
|
End If
|
|
|
|
Printer.EndDoc
|
|
End Sub
|
|
|
|
|
|
Public Sub BehaelterMaxiamlVolumenBestimmen()
|
|
On Error GoTo Errorhandler
|
|
Dim Behaelter As CBehaelter
|
|
|
|
Set Behaelter = New CBehaelter
|
|
|
|
Dim i As Integer
|
|
For i = 1 To 5
|
|
If Behaelter.LoadFromIni(i) Then
|
|
If g_dblVolumenGrosserBehaelter < Behaelter.m_OVolumen Then
|
|
g_dblVolumenGrosserBehaelter = Behaelter.m_OVolumen
|
|
End If
|
|
End If
|
|
Next
|
|
|
|
Exit Sub
|
|
Errorhandler:
|
|
LogIntoDB "Fehler " & Err.Number & " in BehaelterMaxiamlVolumenBestimmen(): " & Err.Description, "Softwarefehler"
|
|
End Sub
|
|
|
|
|
|
Public Sub fillcmbImpulswertigkeiten(MyComboBox As ComboBox)
|
|
On Error GoTo Errorhandler
|
|
Dim strImpulsertigkeiten As String
|
|
Dim varEintrag As Variant
|
|
|
|
MyComboBox.Clear
|
|
MyComboBox.text = "Bitte auswählen..."
|
|
strImpulsertigkeiten = g_App.Settings.GetOrSetIniWert("Verbundzaehlerpruefung", "NebenzaehlerImpulswertigkeiten", "90510 (612 MID)|106104 (612 MT)|33512 (612 MTW-Er56)|10000 (612 mech Opt.)|1000 (620 WPV-MS)")
|
|
For Each varEintrag In Split(strImpulsertigkeiten, "|")
|
|
Debug.Print varEintrag
|
|
MyComboBox.AddItem varEintrag
|
|
Next
|
|
Exit Sub
|
|
Errorhandler:
|
|
LogIntoDB "Fehler " & Err.Number & " in fillcmbImpulswertigkeiten: " & Err.Description, "Softwarefehler"
|
|
End Sub
|
|
|
|
|
|
|
|
Public Sub SelbsttestAusfuehren()
|
|
Dim objForm As frmSelbsttest
|
|
Set objForm = New frmSelbsttest
|
|
objForm.Show vbModal
|
|
End Sub
|
|
|
|
Public Function URLdecode(ByRef text As String) As String
|
|
Const Hex = "0123456789ABCDEF"
|
|
Dim lngA As Long, lngB As Long, lngChar As Long, lngChar2 As Long
|
|
URLdecode = text
|
|
lngB = 1
|
|
For lngA = 1 To LenB(text) - 1 Step 2
|
|
lngChar = Asc(MidB$(URLdecode, lngA, 2))
|
|
Select Case lngChar
|
|
Case 37
|
|
lngChar = InStr(Hex, MidB$(text, lngA + 2, 2)) - 1
|
|
If lngChar >= 0 Then
|
|
lngChar2 = InStr(Hex, MidB$(text, lngA + 4, 2)) - 1
|
|
If lngChar2 >= 0 Then
|
|
MidB$(URLdecode, lngB, 2) = Chr$((lngChar * &H10&) Or lngChar2)
|
|
lngA = lngA + 4
|
|
Else
|
|
If lngB < lngA Then MidB$(URLdecode, lngB, 2) = MidB$(text, lngA, 2)
|
|
End If
|
|
Else
|
|
If lngB < lngA Then MidB$(URLdecode, lngB, 2) = MidB$(text, lngA, 2)
|
|
End If
|
|
Case 43
|
|
MidB$(URLdecode, lngB, 2) = " "
|
|
Case Else
|
|
If lngB < lngA Then MidB$(URLdecode, lngB, 2) = MidB$(text, lngA, 2)
|
|
End Select
|
|
lngB = lngB + 2
|
|
Next lngA
|
|
URLdecode = LeftB$(URLdecode, lngB - 1)
|
|
End Function
|
|
|
|
Public Function URLencode(ByRef text As String) As String
|
|
Const Hex = "0123456789ABCDEF"
|
|
Dim lngA As Long, lngChar As Long
|
|
URLencode = text
|
|
For lngA = LenB(URLencode) - 1 To 1 Step -2
|
|
lngChar = Asc(MidB$(URLencode, lngA, 2))
|
|
Select Case lngChar
|
|
Case 48 To 57, 65 To 90, 97 To 122
|
|
Case 32
|
|
MidB$(URLencode, lngA, 2) = "+"
|
|
Case Else
|
|
URLencode = LeftB$(URLencode, lngA - 1) & "%" & Mid$(Hex, (lngChar And &HF0) \ &H10 + 1, 1) & Mid$(Hex, (lngChar And &HF&) + 1, 1) & MidB$(URLencode, lngA + 2)
|
|
End Select
|
|
Next lngA
|
|
End Function
|
|
|
|
|
|
|
|
|
|
Public Function GetGlobaleEinstellung(strSektion As String, strName As String) As String
|
|
Dim strSQL As String
|
|
Dim rs As CRecordset
|
|
|
|
strSQL = "SELECT Wert from GlobaleEinstellungen where Sektion = '" & strSektion & "' and Name = '" & strName & "'"
|
|
Set rs = New CRecordset
|
|
rs.openRS strSQL, True
|
|
If Not rs.EOF Then
|
|
GetGlobaleEinstellung = rs.getStringValue("Wert")
|
|
DebugMsg "Lese GetGlobaleEinstellung [" & strSektion & "] " & strName & " = '" & GetGlobaleEinstellung & "'"
|
|
Else
|
|
GetGlobaleEinstellung = ""
|
|
End If
|
|
End Function
|
|
|
|
|
|
|
|
Public Function Verschiebe_Prueffehler_Befundpruefung_Eichung(lngPruefgangNr As Long)
|
|
' Verschiebt alle Datensätze aus dem angegeben Prüfgang
|
|
' aus der Tabelle Prueffehler in die Tabelle Prueffehler_Eichung,
|
|
' wenn in der AutragPosition das Flag Eichung oder Befundpruefung gesetzt ist
|
|
' zwecks Separieung der Prüffehler (Eichung und Befundprüfungen) . i.A. von Peter Buch, 28.3.2017
|
|
|
|
Dim rs As ADODB.Recordset
|
|
Dim rsSerienNr As CRecordset
|
|
Dim strSQL As String
|
|
Dim cmd As ADODB.command
|
|
Dim Param As ADODB.Parameter
|
|
Dim lngRecordsaffected As Long
|
|
Dim errnum As Long
|
|
Dim errdesc As String
|
|
Dim blnIsInTrans As Boolean
|
|
Dim strListeSerienNr As String
|
|
Dim varSeriennr As Variant
|
|
|
|
Const DELIMITER = " " ' SPACE damit TRIM() funktioniert
|
|
|
|
On Error GoTo Errorhandler
|
|
|
|
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
|
|
strSQL = "SELECT AlleAuftragPositionen.AuftragNr, AlleAuftragPositionen.PositionNr, Prueffehler.SerienNr, Prueffehler.PruefgangNr from AlleAuftragPositionen "
|
|
strSQL = strSQL & "inner join AuftragPositionSerienNr on AuftragPositionSerienNr.AuftragNr = AlleAuftragPositionen.AuftragNr and AuftragPositionSerienNr.PositionNr = AlleAuftragPositionen.PositionNr "
|
|
strSQL = strSQL & "inner join Prueffehler on Prueffehler.SerienNr = AuftragPositionSerienNr.SerienNr and Prueffehler.PruefgangNr = AuftragPositionSerienNr.PruefgangNr "
|
|
strSQL = strSQL & "where (AlleAuftragPositionen.Eichung = 1 or AlleAuftragPositionen.Befundpruefung = 1) and Prueffehler.PruefgangNr = " & lngPruefgangNr
|
|
|
|
Set rs = New ADODB.Recordset
|
|
rs.Open strSQL, g_App.getDB.getConnection, adOpenStatic, adLockOptimistic
|
|
strListeSerienNr = ""
|
|
|
|
' Falls in diesem Prüfgang keine Eichungen / Befundprüfungs-Aufträge (mit Datensätze in Prueffehler) dabei sind => Ausstieg
|
|
If rs.EOF Then Exit Function
|
|
|
|
Do While Not rs.EOF
|
|
strListeSerienNr = strListeSerienNr & rs("SerienNr") & DELIMITER
|
|
rs.MoveNext
|
|
Loop
|
|
strListeSerienNr = Trim(strListeSerienNr)
|
|
rs.Close
|
|
Set rs = Nothing
|
|
|
|
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
|
|
For Each varSeriennr In Split(strListeSerienNr, DELIMITER)
|
|
Set cmd = New ADODB.command
|
|
cmd.ActiveConnection = g_App.getDB.getConnection
|
|
'''''''''''''''''''''''''''''''''''''''''''''''
|
|
strSQL = "INSERT INTO Prueffehler_Eichung SELECT * FROM Prueffehler WITH (NOLOCK) WHERE SerienNr = " & CStr(varSeriennr) & " AND PruefgangNr = " & CStr(lngPruefgangNr)
|
|
cmd.CommandText = strSQL
|
|
cmd.ActiveConnection.beginTrans
|
|
blnIsInTrans = True
|
|
DebugMsg strSQL
|
|
cmd.Execute lngRecordsaffected
|
|
|
|
If lngRecordsaffected > 0 Then
|
|
strSQL = "DELETE FROM Prueffehler WHERE PruefgangNr = " & lngPruefgangNr & " AND SerienNr = " & CStr(varSeriennr)
|
|
cmd.CommandText = strSQL
|
|
DebugMsg strSQL
|
|
cmd.Execute lngRecordsaffected
|
|
cmd.ActiveConnection.CommitTrans
|
|
DebugMsg "Prüffehler (Eichung und Befundprüfungen) für Seriennummer " & CStr(varSeriennr) & " des Prüfgangs " & lngPruefgangNr & " in die Tabelle Prueffehler_Eichung verschoben."
|
|
blnIsInTrans = False
|
|
Else
|
|
DebugMsg "Prüffehler (Eichung und Befundprüfungen) für Seriennummer " & CStr(varSeriennr) & " des Prüfgangs " & lngPruefgangNr & " in die Tabelle Prueffehler_Eichung NICHT verschoben."
|
|
LogIntoDB "Verschiebe_Prueffehler_Befundpruefung_Eichung: RollbackTrans", ""
|
|
cmd.ActiveConnection.RollbackTrans
|
|
blnIsInTrans = False
|
|
End If
|
|
'''''''''''''''''''''''''''''''''''''''''''''''
|
|
Set cmd = Nothing
|
|
Next
|
|
|
|
Exit Function
|
|
Errorhandler:
|
|
errnum = Err.Number
|
|
errdesc = Err.Description
|
|
LogIntoDB "Fehler " & errnum & " in Verschiebe_Prueffehler_Befundpruefung_Eichung(" & lngPruefgangNr & "): " & errdesc, "Softwarefehler"
|
|
|
|
' ggf vorhandene Transaktion abbrechen
|
|
If Not cmd Is Nothing Then
|
|
If Not cmd.ActiveConnection Is Nothing Then
|
|
If blnIsInTrans Then
|
|
cmd.ActiveConnection.RollbackTrans
|
|
blnIsInTrans = False
|
|
End If
|
|
End If
|
|
End If
|
|
End Function
|
|
|
|
|
|
|
|
Public Sub DoScreenshot()
|
|
Screen.MousePointer = vbHourglass
|
|
SleepWithEvents 1000, True
|
|
DoSnapshot True, "\\SLA12file\Auftrag\PruefstationLogdateien\P" & g_App.PruefstationNr & "_" & Format(Now(), "yyyy-mm-dd-hh-mm-ss") & ".bmp"
|
|
SleepWithEvents 1000, True
|
|
Screen.MousePointer = vbNormal
|
|
End Sub
|
|
|
|
|
|
Public Function GetSollpruefzeit_s(dblSolldurchfluss_m3h As Double, dblPruefmenge_liter) As Long
|
|
If dblSolldurchfluss_m3h = 0 Then
|
|
GetSollpruefzeit_s = 0
|
|
Exit Function
|
|
End If
|
|
|
|
GetSollpruefzeit_s = 3.6 * dblPruefmenge_liter / dblSolldurchfluss_m3h
|
|
If GetSollpruefzeit_s < 60 Then
|
|
GetSollpruefzeit_s = 60
|
|
End If
|
|
End Function
|
|
|
|
|
|
|
|
|
|
Public Sub DoStichprobensteuerung(ColEinbauplatz As Collection)
|
|
On Error GoTo Errorhandler
|
|
|
|
' Neu RH 17.1.2018
|
|
' Stichprobensteuerung soll nach der Regulierung stattfinden
|
|
|
|
Dim strPath As String
|
|
Dim Pruefzaehler As CPruefzaehler
|
|
Dim Einbauplatz As CEinbauplatz
|
|
Dim strCommandparameter As String
|
|
Dim lngReturn As Long
|
|
Dim ersterEingebauterPruefzaehler As CPruefzaehler
|
|
|
|
strPath = Trim(g_App.Settings.readStringValue("Stichprobensteuerung", "Path", ""))
|
|
If strPath = "" Then
|
|
'' kein Pfad definiert. Stichprobensteuerung an dieser Prüfstation ist somit deaktiviert
|
|
Exit Sub
|
|
End If
|
|
|
|
strCommandparameter = g_App.PruefstationNr
|
|
|
|
For Each Einbauplatz In ColEinbauplatz
|
|
Set Pruefzaehler = Einbauplatz.getPruefzaehler
|
|
strCommandparameter = strCommandparameter & "|"
|
|
|
|
If Not Pruefzaehler Is Nothing Then
|
|
Select Case Pruefzaehler.getAuftragPosition.getIdentNrObj.getTyp
|
|
Case "MS", "MMS"
|
|
' nur Meistream
|
|
If Mid(Pruefzaehler.getAuftragPosition.getIdentNrObj.GetVakoCode, 25, 1) = "A" Then
|
|
' laut Vako: Deckelfl Composite PN16
|
|
If ersterEingebauterPruefzaehler Is Nothing Then
|
|
Set ersterEingebauterPruefzaehler = Pruefzaehler
|
|
End If
|
|
|
|
' Hänge die SerienNr des MS/MMS an den Commandoparamter dran
|
|
strCommandparameter = strCommandparameter & Pruefzaehler.getSerienNr
|
|
End If
|
|
Case Else
|
|
' für andere Zählertypen werden keine CF verbaut
|
|
End Select
|
|
End If
|
|
Next
|
|
|
|
If Not ersterEingebauterPruefzaehler Is Nothing Then
|
|
'' wir haben mind. einen MS Zaehler, für den wir die Stichprobensteuerung durchführen wollen
|
|
lngReturn = ShellExecute(0, "open", strPath, strCommandparameter, "", SW_SHOW)
|
|
Select Case lngReturn
|
|
Case 2
|
|
MsgBox "Stichprobensteuerung Anwendung (" & strPath & ") konnte nicht gestartet werden. "
|
|
Case 42
|
|
' Handle 42
|
|
Case Else
|
|
End Select
|
|
Else
|
|
' Wir haben keine MS oder MMS
|
|
' nichts tun!
|
|
End If
|
|
Exit Sub
|
|
Errorhandler:
|
|
MsgBox "Fehler " & Err.Number & " in DoStichprobensteuerung(): " & Err.Description & vbCrLf & "Bitte Softwareentwicklung informieren!"
|
|
LogIntoDB "Fehler " & Err.Number & " in DoStichprobensteuerung(): " & Err.Description, "Stichprobensteuerung"
|
|
End Sub
|
|
|
|
|
|
|
|
|