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