VERSION 1.0 CLASS BEGIN MultiUse = -1 'True Persistable = 0 'NotPersistable DataBindingBehavior = 0 'vbNone DataSourceBehavior = 0 'vbNone MTSTransactionMode = 0 'NotAnMTSObject END Attribute VB_Name = "CPruefzaehler" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = True Attribute VB_PredeclaredId = False Attribute VB_Exposed = False Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes" Attribute VB_Ext_KEY = "Top_Level" ,"Yes" '============================================================================== ' ' File : Pruefzaehler.cls ' Author : Reinhard Henning ' Date : 18.03.1999 ' Version: 0.01 ' '============================================================================== ' ' Abstraktion eines Prüfzählers ' ' Hier hier verwalteten Daten stammen aus verschiedenen Datenbanktabellen. ' Um einen Testprüfzähler, der nicht in der Datenbank gespeichert ist, ' ebenfalls verwalten zu können, können viele Member über entsprechende ' set-Methoden von aussen beschrieben werden. ' ' Um ein Prüfzählerobjekt aus der Datenbank zu laden, ist nur ' ' load(lSerienNr) ' ' durchzuführen. Weitere set-Methoden sollten dann nicht ' mehr verwendet werden. ' '============================================================================== ' ' History: ' ' Author : Reinhard Henning ' Date : 18.03.1999 ' Version: 0.01 ' ' Erste dokumentierte Version. ' ' Änderungen: ' neu 21.7.99: ' m_KZPVersion ' m_Bemerkung ' m_AuftragPositionSerienNr '============================================================================== Option Explicit ' Private Member ' -------------- Private m_lSerienNr As Long ' aus Tabelle "AuftragPositionSerienNr" oder direkt vorgegeben Private m_lIdentNr As Long ' aus Tabelle "AuftragPosition" Private m_nKZP As Integer ' aus Tabelle "AuftragPosition" Private m_sPruefklasseKZ As String ' aus Tabelle "KZP" oder direkt vorgegeben Private m_Auftrag As CAuftrag ' aus Tabelle "Auftrag" Private m_AuftragPosition As CAuftragPosition ' aus Tabelle "AuftragPosition" Private m_IdentNr As CIdentNr ' aus Tabelle "IdentNr" Private m_KZP As CKZP ' aus Tabelle "KZP" oder nothing Private m_Pruefpunkte As CPruefpunkte ' aus Tabelle "Pruefpunkte" oder nothing Private m_Vorpruefpunkte As CVorpruefpunkte 'neu RH 12.12.2001 Private m_KZPVersion As Long ' neu 21.7.99, aus Tabelle KZP und Auftragposition Private m_Bemerkung As String ' neu 21.7.99 Private m_AuftragPositionSerienNr As CAuftragPositionSerienNr ' neu 21.7.99 Private m_Prueffehler As CPrueffehler Private m_blnAusgedatet As Boolean Private m_intAnzahlPaletten As Integer Public m_blnIsEncoder As Boolean Public m_lng_LWLImpulswertigkeit As Long Public m_strKundeneigeneSerienNr As String Public m_bNurKaltPruefbar As Boolean ' neu RH 5.6.2013 Public m_strPruefpunktInfo As String 'zum testen der Prüfpunkt-Ermittlung Public m_Verbundzaehler As CVerbundzaehler 'für US FW2 Zähler: Public m_b_u8_system_flags_saved As Boolean Public m_b_u8_system_flags As Byte ' Member neu initialisieren ' Private Sub init() m_lSerienNr = 0 m_lIdentNr = 0 m_nKZP = 0 Set m_Auftrag = Nothing Set m_AuftragPosition = Nothing Set m_IdentNr = Nothing Set m_KZP = Nothing Set m_Pruefpunkte = New CPruefpunkte Set m_AuftragPositionSerienNr = Nothing End Sub ' Serien-Nr. des Prüfzählers neu vorgeben ' Public Sub setSerienNr(lSerienNr As Long) m_lSerienNr = lSerienNr End Sub ' @return Serien-Nr. des Prüfzählers ' Public Function getSerienNr() As Long getSerienNr = m_lSerienNr End Function Public Function IstVerbundZaehler() As Boolean 'geändert am 14.02.2003 PF: Zusatztext kann auch "WPV" enthalten 'geändert am 20.01.2004 PF: TypText kann auch "Meitwin" enthalten If Left(m_IdentNr.getTyp, 3) = "WPV" Or _ Left(m_IdentNr.getTypzusatz, 3) = "WPV" Or _ Left(m_IdentNr.getTyp, 7) = "Meitwin" Then IstVerbundZaehler = True End If End Function Public Function getAuftragPositionSerienNr() As CAuftragPositionSerienNr Set getAuftragPositionSerienNr = m_AuftragPositionSerienNr End Function Public Sub SetAuftragPositionSerienNr(AuftragpositionSerienNr As CAuftragPositionSerienNr) Set m_AuftragPositionSerienNr = AuftragpositionSerienNr End Sub ' Ident-Nr. vorgeben ' ' @param lIdentNr neue Ident-Nr. ' Public Sub setIdentNr(lIdentNr As Long) m_lIdentNr = lIdentNr Set m_IdentNr = Nothing End Sub ' @return hart vorgegebene oder aus "AuftragsPosition" geladene Ident-Nr. ' Public Function getIdentNr() As Long getIdentNr = m_lIdentNr End Function ' @return IdentNr-Objekt oder nothing ' Public Function getIdentNrObj() As CIdentNr Set getIdentNrObj = m_IdentNr End Function ' KZP-Nr. hart vorgeben ' Um keine Inkonsistenzen entstehen zu lassen, wird ' ein evtl. bereits vorhandenes KZP-Objekt auf nothing gesetzt! ' ' @param nKZP Neue KZP-Nr. ' ' @see setPruefklasseKZ ' Public Sub setKZPNr(nKZP As Integer) m_nKZP = nKZP Set m_KZP = Nothing End Sub ' @return hart vorgegebene oder aus "AuftragPosition" geladene KZP-Nr. ' Public Function getKZPNr() As Integer getKZP = m_nKZP End Function ' @return Referenz auf das KZP-Objekt zu der Ident-Nr. der ' Prüfpunkte oder nothing ' Public Function getKZP() As CKZP Set getKZP = m_KZP End Function ' @return Bemerkung Public Function getBemerkung() As String getBemerkung = m_Bemerkung End Function ' erneutes setzen der Bemerkung Public Sub setBemerkung(Bemerkung As String) m_Bemerkung = Bemerkung savebemerkung End Sub ' Speichert FabNr in zugehörigem Feld von AuftragPsoitionSeriennummer Private Sub saveFabNr(lngFabNr As Long) Dim sSQL As String Dim rs As CRecordset On Error GoTo saveFabNrErr ' Schauen, ob es diese Auftragsposition schon gibt ' ------------------------------------------------ sSQL = "SELECT * FROM AuftragPositionSerienNr " sSQL = sSQL & "WHERE " sSQL = sSQL & "SerienNr = " & getSerienNr() sSQL = sSQL & " order by Wiederholungen;" Set rs = New CRecordset If Not rs.openRS(sSQL) Then Exit Sub If Not rs.EOF() Then Call rs.setValue("FabNr", lngFabNr) rs.update Else ErrorMsg "saveFabNr: Es gibt keine FabNr für" & getSerienNr() End If Exit Sub saveFabNrErr: ErrorMsg "Konnte FabNr nicht speichern: " & Err End Sub ' Speichert Bemerkung in zugehörigem Feld von AuftragPsoitionSeriennummer Private Sub savebemerkung() Dim sSQL As String Dim rs As CRecordset On Error GoTo saveBemerkungErr ' Schauen, ob es diese Auftragsposition schon gibt ' ------------------------------------------------ sSQL = "SELECT * FROM AuftragPositionSerienNr " sSQL = sSQL & "WHERE " sSQL = sSQL & "SerienNr = " & getSerienNr() sSQL = sSQL & " order by Wiederholungen;" Set rs = New CRecordset If Not rs.openRS(sSQL) Then Exit Sub If Not rs.EOF() Then Call rs.setValue("Bemerkung", getBemerkung()) rs.update Else ErrorMsg "saveBemerkung: Es gibt keine Auftragposition für" & getSerienNr() End If Exit Sub saveBemerkungErr: ErrorMsg "Konnte Bemerkung nicht speichern: " & Err End Sub ' Pruefklasse neu vorgeben. ' Um keine Inkonsistenzen entstehen zu lassen, wird ' ein evtl. bereits vorhandenes KZP-Objekt auf nothing gesetzt! ' ' @param sKZ Neue Prüfklasse ' Public Sub setPruefklasseKZ(sKZ As String) m_sPruefklasseKZ = sKZ Set m_KZP = Nothing End Sub ' @return hart vorgegebenes oder aus dem aus "KZP" geladenes Prüfklassen-Kürzel ' Public Function getPruefklasseKZ() As String getPruefklasseKZ = m_sPruefklasseKZ End Function ' Prüfpunkte-Objekt neu vorgeben ' Public Sub setPruefpunkte(Pruefpunkte As CPruefpunkte) Set m_Pruefpunkte = Pruefpunkte End Sub ' @return Prüfpunkte-Objekt oder nothing ' Public Function getPruefpunkte() As CPruefpunkte Set getPruefpunkte = m_Pruefpunkte End Function ' @return Vorprüfpunkte-Objekt oder nothing ' Public Function getVorpruefpunkte() As CVorpruefpunkte If m_Vorpruefpunkte Is Nothing Then loadVorpruefpunkte End If Set getVorpruefpunkte = m_Vorpruefpunkte End Function ' Prüfpunkte-Objekt neu vorgeben ' Public Sub setVorpruefpunkte(Vorpruefpunkte As CVorpruefpunkte) Set m_Vorpruefpunkte = Vorpruefpunkte End Sub ' Warmwasserzähler? ' Die Information hängt von der Ident-Nr. des Zählers bzw. ' von der Ident-Nr. der Prüfpunkte ab. Die Ident-Nr. der ' Prüfpunkte wird vorrangig verwendet. ' ' @return true = Zähler ist ein Warmwasserzähler ' Public Function isWarmwasserzaehler() As Boolean If Not m_IdentNr Is Nothing Then isWarmwasserzaehler = m_IdentNr.isWarmwasserzaehler() End If End Function ' Serien-Nr. des Prüfzählers auf Vorhandensein überprüfen ' ' @return true = Serien-Nr. des Prüfzählers wurde gefunden Public Function testSerienNr(lSerienNr As Long) As Boolean Dim AuftragpositionSerienNr As CAuftragPositionSerienNr Set AuftragpositionSerienNr = New CAuftragPositionSerienNr If Not AuftragpositionSerienNr.load(lSerienNr) Then Exit Function End If testSerienNr = True End Function Public Function loadForSerienOrFabNummer(lSerienFabNr As Long) As Boolean Dim strSQL As String Dim rs As CRecordset Dim lngSerienNr As Long strSQL = "SELECT SerienNr from AuftragPositionSerienNr where SerienNr = " & lSerienFabNr & " or FabNr = " & lSerienFabNr & " order by AnlageDatum desc" Set rs = New CRecordset rs.openRS strSQL, True If rs.EOF Then loadForSerienOrFabNummer = False Exit Function Else lngSerienNr = rs.getLongValue("SerienNr") loadForSerienOrFabNummer = loadForSerienNr(lngSerienNr) End If End Function Public Function loadForSerienOrKundeneigene(strSearch As String) As Boolean Dim strSQL As String Dim rs As CRecordset Dim lngSerienNr As Long If Val(strSearch) = 0 Then strSQL = "SELECT SerienNr from AuftragPositionSerienNr where KundeneigeneSerienNr = '" & strSearch & "' order by AnlageDatum desc" Else strSQL = "SELECT SerienNr from AuftragPositionSerienNr where SerienNr = " & Val(strSearch) & " or KundeneigeneSerienNr = '" & strSearch & "' order by AnlageDatum desc" End If Debug.Print strSQL Set rs = New CRecordset rs.openRS strSQL, True If rs.EOF Then loadForSerienOrKundeneigene = False Exit Function Else lngSerienNr = rs.getLongValue("SerienNr") loadForSerienOrKundeneigene = loadForSerienNr(lngSerienNr) End If End Function Public Function loadForSerienOrFabNummerOrKundeneigene(strSearch As String) As Boolean Dim strSQL As String Dim rs As CRecordset Dim lngSerienNr As Long strSQL = "SELECT SerienNr from AuftragPositionSerienNr where SerienNr = " & Val(strSearch) & " or FabNr = " & Val(strSearch) & " or KundeneigeneSerienNr = '" & strSearch & "' order by AnlageDatum desc" Set rs = New CRecordset rs.openRS strSQL, True If rs.EOF Then loadForSerienOrFabNummerOrKundeneigene = False Exit Function Else lngSerienNr = rs.getLongValue("SerienNr") loadForSerienOrFabNummerOrKundeneigene = loadForSerienNr(lngSerienNr) End If End Function ' Prüfzählerdaten zu der angegebenen Serien-Nr. laden ' Public Function loadForSerienNr(lSerienNr As Long, Optional AuftragNr As Long) As Boolean Dim strSQL As String Dim Auftrag As CAuftrag Dim AuftragPosition As CAuftragPosition Dim KZP As CKZP Dim Pruefpunkte As CPruefpunkte Dim IdentNrObj As CIdentNr Dim AuftragpositionSerienNr As CAuftragPositionSerienNr Dim sPruefklasseKZ As String Dim Metrolog As String Dim KZPVersion As Long Dim IdentNr As Long Dim strKZP As String Dim Pruefpunkte_neu As CPruefpunkte Dim bln_KZPoderMetrologVonHandEingegeben As Boolean Dim strBestellcode As String Dim lngBestellgruppe As Long If False Then loadForSerienNr = loadForSerienNr_neu(lSerienNr, AuftragNr) Exit Function End If bln_KZPoderMetrologVonHandEingegeben = False On Error GoTo loadForSerienNrErr Call init Set AuftragpositionSerienNr = loadAuftragPositionSerienNr(lSerienNr, AuftragNr) If AuftragpositionSerienNr Is Nothing Then loadForSerienNr = False Exit Function End If DebugMsg "loadForSerienNr " & lSerienNr & " aus " & AuftragpositionSerienNr.getAuftragNr & "/" & AuftragpositionSerienNr.getPositionNr ' Auftragsdaten holen ' ------------------- Set AuftragPosition = loadAuftragPositionForSerienNr() If AuftragPosition Is Nothing Then Exit Function End If Set Auftrag = loadAuftrag(AuftragPosition.getAuftragNr()) If Auftrag Is Nothing Then Exit Function End If Set m_Auftrag = Auftrag ' Prüfpunkte laden ' ---------------- Set Pruefpunkte = New CPruefpunkte Pruefpunkte.mstr_Kundenmaterialnr = AuftragPosition.m_strKundenmaterialnummer ' PruefklasseKZ bestimmen '------------------------ If AuftragPosition.getMetrolog() <> "" Then Metrolog = Trim(AuftragPosition.getMetrolog()) m_sPruefklasseKZ = Metrolog sPruefklasseKZ = m_sPruefklasseKZ Else Debug.Print "AuftragPosition.getMetrolog ist leer" End If ' IdentNr laden ' ------------- IdentNr = AuftragPosition.getIdentNr() Set IdentNrObj = loadIdentNr(IdentNr) If IdentNrObj Is Nothing Then DebugMsg "Kein Eintrag in Tabelle IdentNr zur IdentNr=" & IdentNr ' Exit Function GoTo DatenSchreiben End If ' zuerst in Tabelle Spezifikationen reinschauen If GetPruefpunkteFromSpezifikationen(AuftragPosition, Auftrag, IdentNrObj, Pruefpunkte_neu) = True Then Set Pruefpunkte = Pruefpunkte_neu ' wenn was gefunden, dann fertig GoTo DatenSchreiben End If If IdentNrObj.GetVakoCode <> "" Then ' VakoCode Behandlung Dim objVakoCode As CVakoCode Set objVakoCode = New CVakoCode objVakoCode.load IdentNrObj.GetVakoCode If objVakoCode.GetWert("Kaeltezaehler") = "1" Then m_bNurKaltPruefbar = True End If If Pruefpunkte.createFromVakoCode(objVakoCode, AuftragPosition) Then ' OK! Prüfunkte konnten geladen werden If m_sPruefklasseKZ = "" And objVakoCode.GetWert("Metrolog") <> "" Then m_sPruefklasseKZ = objVakoCode.GetWert("Metrolog") End If If Pruefpunkte.getSpezifikationID > 0 Then ' Spezifikation merken wegen der Fehlergrenzen für PDA '''''''''''''''' ' vorhandenen Wert aber nicht überschreiben! strSQL = "SELECT len(VakoFehlerrahmen) as AnzahlZeichen from IdentNr where IdentNr = " & IdentNrObj.getNr Debug.Print strSQL Dim rs As CRecordset Set rs = New CRecordset rs.openRS strSQL, True If Not rs.EOF Then ' IdentNr ist vorhanden If rs.getLongValue("AnzahlZeichen") = 0 Then ' kein Wert vorhanden, also SpecifikationsID eintragen strSQL = "UPDATE IdentNr set VakoFehlerrahmen = 'SpezifikationID=" & Pruefpunkte.getSpezifikationID & "' where IdentNr = " & IdentNrObj.getNr g_App.getDB.getConnection.Execute strSQL WriteToLog strSQL End If End If '''''''''''''''' ElseIf Pruefpunkte.getPruefklasseKZ <> "" Then strSQL = "UPDATE IdentNr set VakoFehlerrahmen = 'IdentNr=" & Pruefpunkte.getIdentNr & ";Metrolog=" & Pruefpunkte.getPruefklasseKZ & "' where IdentNr = " & IdentNrObj.getNr g_App.getDB.getConnection.Execute strSQL WriteToLog strSQL End If If Pruefpunkte.getPruefpunkte.Count > 0 Then 'Erfolg GoTo DatenSchreiben End If Else If sPruefklasseKZ = "" Then If objVakoCode.GetWert("Metrolog") <> "" Then Metrolog = objVakoCode.GetWert("Metrolog") End If ' Irgendwas ist schiefgelaufen ' Hier wäre eine Benutzereingabe hilfreich 'ErrorMsg "Es konnten keine Prüfpunkte für den VakoCode gefunden werden." If Metrolog <> "" And IdentNr <> 0 Then sPruefklasseKZ = Metrolog Else GoTo DatenSchreiben End If End If End If ElseIf Metrolog <> "" And Metrolog <> "ohne KZP" Then ' Fall 1: AuftragPosition.Metrolog vorhanden, Prüfklasse direkt bestimmen sPruefklasseKZ = Metrolog DebugMsg "Fall 1: Metrolog " & Metrolog & " vorhanden" Else ' Fall 2,3,4,5,6: AuftragPosition.Metrolog leer ' KZP leer ? If AuftragPosition.getKZP = Empty Or AuftragPosition.getKZP = 0 Or AuftragPosition.getKZP = 999 Then 'Fall 4,5,6: KZP leer DebugMsg "Fall 4,5,6: KZP ist leer" ' Bestellcode auswerten lngBestellgruppe = IdentNrObj.GetBestellgruppe() If lngBestellgruppe > 0 Then ' Bestellgruppe vorhanden => Prüfpunkte über Bestellcode bestimmen strBestellcode = Trim(AuftragPosition.GetBestellcode()) If InStr(1, strBestellcode, "-") > 0 Then ' nur den Teil hinter dem Bindestrich betrachten strBestellcode = Mid(strBestellcode, InStr(1, strBestellcode, "-") + 1) End If DebugMsg "Gruppe " & lngBestellgruppe & ", Bestellcode= " & strBestellcode ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Dim Bestellcode As CBestellcode Set Bestellcode = New CBestellcode If Bestellcode.load(strBestellcode, IdentNrObj.GetBestellgruppe) Then ' Bestellcode konnte geladen werden sPruefklasseKZ = Bestellcode.GetWert("Metrolog") ' Metrolog aus Bestellcode ? If sPruefklasseKZ <> "" Then ' hier ist eine Metrologische Klasse über den Bestellcode definiert ' zur Zeit bei "Meistream" der Fall sPruefklasseKZ = Trim(Bestellcode.GetWert("Metrolog")) DebugMsg "Metrolog aus Bestellocde = '" & sPruefklasseKZ & "'" AuftragPosition.setMetrolog sPruefklasseKZ Else 'sPruefklasseKZ = "" ' KZP aus Bestellcode ? strKZP = Bestellcode.GetWert("KZP") If Val(strKZP) > 0 Then ' KZP aus Bestellcode ist gefüllt AuftragPosition.setKZP Val(strKZP) DebugMsg "KZP " & strKZP & " aus Bestellcode!" sPruefklasseKZ = GetPruefklasseFromKZP(AuftragPosition, Auftrag, IdentNrObj) AuftragPosition.setMetrolog sPruefklasseKZ Else ' KZP <= 0 ' Bestellcode vorhanden aber weder Metrolog oder KZP ' dann werden Zähler nach MID geprüft ' If Pruefpunkte.CreateMIDPruefpunkteFromBestellcode_NEU(Bestellcode, AuftragPosition, IdentNrObj) Then ' '''''''''''''''''''''''''''''''''''''''' ' ' ' ' OK, Zähler wird nach MID geprüft ' ' ' '''''''''''''''''''''''''''''''''''''''' ' ' AuftragPosition.setPrf_nach_MID True ' AuftragPosition.save Auftrag ' GoTo DatenSchreiben ' Else ' ErrorMsg "Prüfpunkte nach MID konnten nicht ermittelt werden!" ' sPruefklasseKZ = Pruefklasse_durch_KZP_Metrolog_Eingabe(AuftragPosition, Auftrag, IdentNrObj) ' End If If Pruefpunkte.CreateMIDPruefpunkteFromBestellcode(Bestellcode) Then '''''''''''''''''''''''''''''''''''''''' ' ' OK, Zähler wird nach MID geprüft ' '''''''''''''''''''''''''''''''''''''''' ' neu RH 11.2.2013 ' Sonderregel 7.4.2014 AB If Pruefpunkte.CreatePruefpunkteFromSpezifikationen(Bestellcode, Me.getAuftrag) Then Pruefpunkte.m_bPruefung_nach_MID = False m_Bemerkung = m_Bemerkung & "Prüfpunkte kommen aus Tabelle 'Spezifikationen' mit ID=" & Pruefpunkte.m_lngSpezifikationID & vbCrLf Pruefpunkte.setInfo m_Bemerkung GoTo DatenSchreiben Else AuftragPosition.setPrf_nach_MID True AuftragPosition.save Auftrag GoTo DatenSchreiben End If Else ' keine Metrolog, keine MID, keine KZP aber Bestellcode ' Metrolog aus Logo und Typ z.B. über Spezifikationen bestimmen If Pruefpunkte.CreatePruefpunkteFromSpezifikationen(Bestellcode, Me.getAuftrag) Then m_Bemerkung = m_Bemerkung & "Prüfpunkte kommen aus Spezifikationen " & Pruefpunkte.m_lngSpezifikationID & vbCrLf GoTo DatenSchreiben Else sPruefklasseKZ = GetMetrologFromSpezifikationen(Bestellcode) If sPruefklasseKZ = "" Then ErrorMsg "Prüfpunkte nach MID konnten nicht ermittelt werden!" sPruefklasseKZ = Pruefklasse_durch_KZP_Metrolog_Eingabe(AuftragPosition, Auftrag, IdentNrObj) End If End If End If 'CreateMIDPruefpunkteFromBestellcode End If ' KZP = 0 End If 'sPruefklasseKZ = "" Else ErrorMsg "Bestellcode " & strBestellcode & " konnte nicht ausgewertet werden für SerienNr=" & lSerienNr & " und Bestellgruppe=" & lngBestellgruppe sPruefklasseKZ = Pruefklasse_durch_KZP_Metrolog_Eingabe(AuftragPosition, Auftrag, IdentNrObj) End If 'Bestellcode.load ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Else ErrorMsg "Der Zähler mit der Serien-Nr. " & lSerienNr & " kann nicht nach MID geprüft werden, da die Eigenschaft 'Bestellgruppe' für IdentNr " & IdentNrObj.getNr & " nicht definiert ist!" sPruefklasseKZ = Pruefklasse_durch_KZP_Metrolog_Eingabe(AuftragPosition, Auftrag, IdentNrObj) End If Else 'AuftragPosition.getKZP = Empty Or AuftragPosition.getKZP = 0 'Fall 2,3 KZP ist gefüllt sPruefklasseKZ = GetPruefklasseFromKZP(AuftragPosition, Auftrag, IdentNrObj) End If 'Fall 2,3 End If PPausMetrologUndIdentNr: ' Nun ist die PrüfklasseKZ bekannt DebugMsg "Die Prüfpunkte werden aus der PruefklasseKZ=" & sPruefklasseKZ & " und der IdentNr = " & AuftragPosition.getIdentNr & " bestimmt." ' RH neu 18.7.2012 ' nachschauen, ob es in der Spezifikationen eine CSD Sonderregel gibt If GetPruefpunkteFromSpezifikationen(AuftragPosition, Auftrag, IdentNrObj, Pruefpunkte_neu) = True Then 'If MsgBox("Es gibt spezielle Prüfpunkte nach CSD/QA_M für diesen Kunden (" & Auftrag.getKundenNr & "). Möchten Sie diese Prüfpunkte verwenden?", vbYesNo Or vbDefaultButton1) = vbYes Then Set Pruefpunkte = Pruefpunkte_neu 'End If Else If Not Pruefpunkte.load(AuftragPosition.getIdentNr(), sPruefklasseKZ) Then DebugMsg "CPruefzaehler.load: Pruefpunkte zu IdentNr:" & AuftragPosition.getIdentNr() & " KZP:" & AuftragPosition.getKZP() & " konnte nicht geladen werden." Set Pruefpunkte = Nothing End If ' RH 20.7.2007 (i.A. A.Beyer): Prüfpunkte müssen neu eingegeben werden wenn KZP=10 und Metrolog=SONDERV. If AuftragPosition.getKZP = 10 And AuftragPosition.getMetrolog = "SONDERV." Then Set Pruefpunkte = Nothing ' RH 9.7.2009 Set Pruefpunkte = New CPruefpunkte End If End If DatenSchreiben: If Not Pruefpunkte Is Nothing Then ' Neu RH 2016-11-28 If Pruefpunkte.getSpezifikationID > 0 Then ' Spezifikation merken wegen der Fehlergrenzen für PDA '''''''''''''''' ' vorhandenen Wert aber nicht überschreiben! strSQL = "SELECT len(VakoFehlerrahmen) as AnzahlZeichen from IdentNr where IdentNr = " & IdentNrObj.getNr Debug.Print strSQL Set rs = New CRecordset rs.openRS strSQL, True If Not rs.EOF Then ' IdentNr ist vorhanden If rs.getLongValue("AnzahlZeichen") = 0 Then ' kein Wert vorhanden, also SpezifikationsID eintragen strSQL = "UPDATE IdentNr set VakoFehlerrahmen = 'SpezifikationID=" & Pruefpunkte.getSpezifikationID & "' where IdentNr = " & IdentNrObj.getNr WriteToLog strSQL g_App.getDB.getConnection.Execute strSQL End If End If '''''''''''''''' End If End If If Not Pruefpunkte Is Nothing Then ' Wenn LWL gewählt ist, dann Prüfzeiten aus Tabelle LWL_Pruefzeiten beziehen If g_blnPrfMitLWL = True And Pruefpunkte.getPruefpunkteCount > 0 Then SetzeLWLPruefzeiten Pruefpunkte.getPruefpunkte, AuftragPosition, IdentNrObj m_lng_LWLImpulswertigkeit = GetLWLImpulswertigkeit(IdentNrObj, AuftragPosition) End If End If ' Daten erst jetzt in Member-Variablen schreiben! ' ----------------------------------------------- m_lSerienNr = lSerienNr m_nKZP = AuftragPosition.getKZP m_lIdentNr = AuftragPosition.getIdentNr() m_Bemerkung = AuftragpositionSerienNr.getBemerkung() m_sPruefklasseKZ = sPruefklasseKZ m_strKundeneigeneSerienNr = AuftragpositionSerienNr.getKundeneigeneSerienNr Set m_Auftrag = Auftrag Set m_AuftragPosition = AuftragPosition Set m_IdentNr = IdentNrObj Set m_KZP = KZP Set m_Pruefpunkte = Pruefpunkte 'DebugMsg " AuftragPosition " & m_AuftragPosition.getAuftragNr & "/" & m_AuftragPosition.getNr LoadForSerienNrOK: loadForSerienNr = True Exit Function loadForSerienNrErr: Call showError("loadForSerienNrErr") Exit Function Resume End Function Private Function GetPruefpunkteFromSpezifikationen(AuftragPosition As CAuftragPosition, Auftrag As CAuftrag, IdentNrObj As CIdentNr, ByRef Pruefpunkte As CPruefpunkte) As Boolean On Error GoTo Errorhandler Dim errorno As Long Dim errordesc As String Dim Pruefpunkt As CPruefpunkt Dim PPNr As Integer Dim Pruefpunktcollection As CPruefpunktCol Dim strCSD As String Dim strTemp As String Dim intRatio As Integer Dim strAusfuehrung As String GetPruefpunkteFromSpezifikationen = False Dim strSQL As String ' Ausführung_Land später aus Vako ' CSD später aus Vako ' neu RH 2015-07-15 If IdentNrObj.GetVakoCode <> "" Then Dim objVako As CVakoCode Set objVako = New CVakoCode If objVako.load(IdentNrObj.GetVakoCode) Then intRatio = Val(Replace(objVako.GetWert("Ratio"), "R", "")) If Left(objVako.GetWert("Ausfuehrung"), 4) = "CSD " Then strCSD = objVako.GetWert("Ausfuehrung") If UBound(Split(strCSD, " ")) >= 1 Then strCSD = Split(strCSD, " ")(0) & " " & Split(strCSD, " ")(1) End If ElseIf Val(Left(objVako.GetWert("Ausfuehrung"), 2)) > 0 Then strAusfuehrung = Left(objVako.GetWert("Ausfuehrung"), 2) End If End If End If ' neu RH 5.9.2013 If AuftragPosition.GetBestellcode <> "" And IdentNrObj.GetBestellgruppe <> 0 Then Dim Bestellcode As CBestellcode Set Bestellcode = New CBestellcode Bestellcode.load AuftragPosition.GetBestellcode, IdentNrObj.GetBestellgruppe strCSD = Bestellcode.GetWert("CSD") intRatio = Bestellcode.GetWert("Verhaeltnis_Q3_Q1") End If 'neu RH Benutze die Metrolog des NZ (Lead Auftrag) Dim strNZ_Metrolog As String Select Case LCase(AuftragPosition.getIdentNrObj.getTyp) Case LCase("meitwin") If AuftragPosition.m_lLead_AuftragNr <> 0 Then Dim NZAuftragPosition As CAuftragPosition '' Set NZAuftragPosition = AuftragPosition.getNZAuftragposition '' If Not NZAuftragPosition Is Nothing Then '' strNZ_Metrolog = NZAuftragPosition.getMetrolog '' End If End If End Select strSQL = "SELECT * From Spezifikationen where 1=1 " strSQL = strSQL & " and (KundenNr = " & Auftrag.getKundenNr & " or KundenNr = 0 or KundenNr is NULL) " If AuftragPosition.getKZP > 0 Then strSQL = strSQL & " and (KZP = " & AuftragPosition.getKZP & ") " Else strSQL = strSQL & " and (KZP is NULL) " End If 'If strCSD <> "" Then strSQL = strSQL & " and (CSD = '" & strCSD & "' or CSD is NULL or CSD like '%;" & strCSD & ";%') " 'End If If AuftragPosition.getMetrolog <> "" Then strSQL = strSQL & " and (Metrolog = '" & AuftragPosition.getMetrolog & "' or Metrolog is NULL) " End If If IdentNrObj.GetKurzBezeichnung <> "" Then strSQL = strSQL & " and (KurzBez = '" & IdentNrObj.GetKurzBezeichnung & "' or KurzBez is NULL) " End If If IdentNrObj.getTyp <> "" Then strSQL = strSQL & " and (Typ = '" & IdentNrObj.getTyp & "' or Typ is NULL) " End If strSQL = strSQL & " and (Typzusatz = '" & IdentNrObj.getTypzusatz & "' or Typzusatz like ';" & IdentNrObj.getTypzusatz & ";' or Typzusatz like '%;*;%' or Typzusatz is NULL)" If IdentNrObj.getNennweite <> 0 Then strSQL = strSQL & " and (Nennweite = " & IdentNrObj.getNennweite & " or Nennweite is NULL) " End If If IdentNrObj.GetTemperatur > 0 Then strSQL = strSQL & " and (Temperatur = " & IdentNrObj.GetTemperatur & " or Temperatur is NULL) " End If If IdentNrObj.getDruck > 0 Then strSQL = strSQL & " and (Druck = " & IdentNrObj.getDruck & " or Druck is NULL) " End If ' NEU RH 10.6.2015 wegen FANr = 3006449 , SNr 15757286 AP 71117933/10 If intRatio > 0 Then strSQL = strSQL & " and (Ratio = 'R" & intRatio & "' or Ratio is null) " End If ' If strNZ_Metrolog <> "" Then ' strSQL = strSQL & " and (Metrolog_NZ = '" & strNZ_Metrolog & "' or Metrolog_NZ is NULL) " ' End If ' strSQL = strSQL & " AND (Q1 is not NULL)" Debug.Print strSQL Dim rs As CRecordset Set rs = New CRecordset rs.openRS strSQL, True GetPruefpunkteFromSpezifikationen = False If Not rs.EOF Then If rs.RecordCount > 1 Then strTemp = vbCrLf & "Es wurden zuviele (" & rs.RecordCount & ") passende Datensätze in Tabelle Spezifikation gefunden: " & vbCrLf & vbCrLf & strSQL & vbCrLf & vbCrLf & "FANr = " & AuftragPosition.GetFertigungsauftragNr & vbCrLf rs.MoveFirst Do While Not rs.EOF strTemp = strTemp & vbCrLf & "ID=" & rs.getLongValue("ID") & vbCrLf rs.MoveNext Loop rs.MoveFirst BenachrichtigeDatenpflege strTemp End If Set Pruefpunkte = New CPruefpunkte Set Pruefpunktcollection = New CPruefpunktCol For PPNr = 1 To 10 If rs.getDoubleValue("Q" & PPNr) > 0 Then ' für mind. einen Durchfluss gibt es Prüfpunkte GetPruefpunkteFromSpezifikationen = True Set Pruefpunkt = New CPruefpunkt Pruefpunkt.setQ rs.getDoubleValue("Q" & PPNr) Pruefpunkt.setFGo rs.getDoubleValue("FGo" & PPNr) Pruefpunkt.setFGu rs.getDoubleValue("FGu" & PPNr) Pruefpunkt.SetTime rs.getDoubleValue("P" & PPNr & "SollPruefZeit") Pruefpunktcollection.Add Pruefpunkt End If Next Pruefpunkte.setPruefpunkte Pruefpunktcollection Pruefpunkte.setInfo "PP aus Tabelle Spezifikationen ID=" & rs.getLongValue("ID") Pruefpunkte.m_lngSpezifikationID = rs.getLongValue("ID") End If Exit Function Errorhandler: GetPruefpunkteFromSpezifikationen = False errorno = Err.Number errordesc = Err.Description LogIntoDB "Fehler " & errorno & " in GetPruefpunkteFromSpezifikationen(): " & Err.Description, "Softwarefehler" End Function Private Function GetPruefklasseFromKZP(ByRef AuftragPosition As CAuftragPosition, ByRef Auftrag As CAuftrag, ByRef IdentNrObj As CIdentNr) As String Dim KZP As CKZP Set KZP = New CKZP If Not AuftragPosition.getKZPVersion = Empty And Not AuftragPosition.getKZPVersion = 0 Then ' Fall 2: KZPVersion vorhanden DebugMsg "Fall 2: KZPVersion vorhanden" ' KZP mit KZP und KZPVersion laden ' --------- If Not KZP.load(AuftragPosition.getKZP(), AuftragPosition.getKZPVersion) Then DebugMsg "CPruefzaehler.GetPruefklasseFromKZP(): KZP (mit KZPNr=" & AuftragPosition.getKZP() & " KZPVersion=" & AuftragPosition.getKZPVersion() & ") konnte nicht geladen werden." Else GetPruefklasseFromKZP = KZP.getPruefklasseKZ DebugMsg " Die daraus ermittelte Prüfklasse ist '" & GetPruefklasseFromKZP & "'" End If Else ' KZPVersion vorhanden ' Fall 3: nur KZP ohne KZPVersion vorhanden ' KZP aus Tabelle IdentNr über Typ/Nennweite/Temperatur/KZP bestimmen If Not KZP.LoadforParameter(IdentNrObj.getTyp, IdentNrObj.getNennweite, IdentNrObj.GetTemperatur, AuftragPosition.getKZP(), Auftrag.getKundenNr) Then DebugMsg "CPruefzaehler.loadForSerienNr: KZP (mit Typ=" & IdentNrObj.getTyp & ",Nennweite=" & IdentNrObj.getNennweite & ",Temperatur=" & IdentNrObj.GetTemperatur & ") konnte nicht geladen werden." Else GetPruefklasseFromKZP = KZP.getPruefklasseKZ DebugMsg " Die daraus ermittelte Prüfklasse ist '" & GetPruefklasseFromKZP & "'" End If End If ' Fall 3 End Function Private Function Pruefklasse_durch_KZP_Metrolog_Eingabe(ByRef AuftragPosition As CAuftragPosition, Auftrag As CAuftrag, IdentNrObj As CIdentNr) As String Dim strKZP As String Dim Metrolog As String Dim KZP As CKZP Dim strKZPVorschlag As String strKZPVorschlag = "" If IdentNrObj.GetKurzBezeichnung = "ZM" And IdentNrObj.getTyp = "MAG" Then strKZPVorschlag = "190" End If ' MID Angaben fehlen, also KZP oder Metrolog vom Bediener anfordern! strKZP = Trim(InputBox("Bitte geben Sie die KZP für Auftrag " & AuftragPosition.getAuftragNr & "/" & AuftragPosition.getNr & " ein." & "Wählen Sie 'Abbrechen' um eine metrologische Klasse eingeben zu können.", "Eingabe der KZP", strKZPVorschlag)) If IsNumeric(strKZP) Then DebugMsg "Der Prüfer hat die KZP " & strKZP & " eingegeben!" AuftragPosition.setKZP Val(strKZP) Pruefklasse_durch_KZP_Metrolog_Eingabe = GetPruefklasseFromKZP(AuftragPosition, Auftrag, IdentNrObj) AuftragPosition.setKZP CLng(strKZP) If MsgBox("Möchten Sie die KZP '" & strKZP & "' für diese Auftragposition speichern ?", vbYesNo) = vbYes Then AuftragPosition.save Auftrag End If Set KZP = New CKZP If KZP.load(Val(strKZP)) Then Pruefklasse_durch_KZP_Metrolog_Eingabe = KZP.getPruefklasseKZ DebugMsg " Die daraus ermittelte Prüfklasse ist '" & Pruefklasse_durch_KZP_Metrolog_Eingabe & "'" End If Else strKZP = "" End If If strKZP = "" Then Metrolog = Trim(InputBox("Bitte geben Sie die metrologische Prüfklasse für Auftrag " & AuftragPosition.getAuftragNr & "/" & AuftragPosition.getNr & " ein", "Eingabe der Prüfklasse", "")) If Metrolog <> "" Then DebugMsg "Der Prüfer hat die Metrolog " & Metrolog & " eingegeben!" AuftragPosition.setMetrolog Metrolog If MsgBox("Möchten Sie die metrologische Klasse '" & Metrolog & "' für diese Auftragposition speichern ?", vbYesNo) = vbYes Then AuftragPosition.save Auftrag End If Pruefklasse_durch_KZP_Metrolog_Eingabe = Metrolog End If 'Metrolog <> "" End If 'strKZP = "" End Function ' @return Auftrag zu dem Prüfzählers ' Public Function getAuftrag() As CAuftrag Set getAuftrag = m_Auftrag End Function ' @return Auftragsposition zu der Serien-Nr. des Prüfzählers oder ' nothing ' Public Function getAuftragPosition() As CAuftragPosition Set getAuftragPosition = m_AuftragPosition End Function ' Auftragsposition zu der Serien-Nr. des Prüfzählers laden ' Private Function loadAuftragPositionForSerienNr() As CAuftragPosition Dim AuftragpositionSerienNr As CAuftragPositionSerienNr Dim AuftragPosition As CAuftragPosition ' Todo: lSeriennr ist überflüssig in dieser Funktion, auch Funktionsaufrufe schlanker machen ' Zugehörige Auftragsposition laden. Wenn diese nicht geladen werden ' kann, liegt eine Inkonsistenz vor, die auf jeden Fall als harter Fehler ' zu werten ist. Set AuftragPosition = New CAuftragPosition If Not AuftragPosition.load(m_AuftragPositionSerienNr.getAuftragNr(), m_AuftragPositionSerienNr.getPositionNr()) Then ErrorMsg "Es konnte keine Auftragsposition (" & m_AuftragPositionSerienNr.getAuftragNr() & " / " & m_AuftragPositionSerienNr.getPositionNr() & ") geladen werden." Exit Function End If Set loadAuftragPositionForSerienNr = AuftragPosition End Function ' Auftrag zu der übergebenen Auftrags-Nr. laden ' Private Function loadAuftrag(lAuftragNr As Long) As CAuftrag Dim Auftrag As CAuftrag Set Auftrag = New CAuftrag If Not Auftrag.load(lAuftragNr, False) Then Exit Function End If Set loadAuftrag = Auftrag End Function Private Function loadIdentNr(lIdentNr As Long) As CIdentNr Dim IdentNr As CIdentNr Set IdentNr = New CIdentNr If Not IdentNr.loadForNr(lIdentNr) Then Exit Function End If Set loadIdentNr = IdentNr End Function Private Function loadAuftragPositionSerienNr(SerienNr As Long, Optional lngAuftragNr As Long) As CAuftragPositionSerienNr Set m_AuftragPositionSerienNr = New CAuftragPositionSerienNr If m_AuftragPositionSerienNr.load(SerienNr, lngAuftragNr) Then Set loadAuftragPositionSerienNr = m_AuftragPositionSerienNr End If End Function '------------------------------------------------------------------------------ ' Private Funktionalität '------------------------------------------------------------------------------ ' Helper für Fehlerausgaben ' ' @param sInfo optionaler Hinweistext ' Private Sub showError(sMethod As String, Optional sInfo As String) Call modError.showError("CPruefzaehler." + sMethod, sInfo) End Sub Public Function GetImpulseLwl() As Long Dim ANZEIGE As String Dim ImpulseAnz As Long Dim UmrechnungsFaktor As Double Dim AnzeigeEinheitFaktor As Long Dim EinheitID As Integer Dim sSQL As String Dim rs As CRecordset On Error GoTo GetImpulseError ANZEIGE = m_AuftragPosition.getAnzeige ' Nachschlagen von EinheitID über Tabelle Einheit aus AuftragPosition.Anzeige ' --------------------------------------------------------------------------- sSQL = "SELECT EinheitID " sSQL = sSQL & "FROM Einheit where Anzeige = '" & m_AuftragPosition.getAnzeige & "';" Set rs = New CRecordset If Not rs.openRS(sSQL) Then ErrorMsg ("SQL-Fehler bei CPruefzaehler.GetImpulseLwl") End If If Not rs.EOF() Then Else ErrorMsg ("Die EinheitID konnte für die Anzeige '" & m_AuftragPosition.getAnzeige & "' nicht ermittelt werden.") Exit Function End If EinheitID = rs.getIntValue("EinheitID") Set rs = Nothing Set rs = New CRecordset sSQL = "SELECT LwlPulse_Pro_Anzeige, UmrechnungsFaktor, AnzeigeEinheitFaktor, AnzahlPaletten from IdentNrZaehlwerk where " sSQL = sSQL & "EinheitID = " & EinheitID & " " sSQL = sSQL & "and Typenbereiche like '%;" & CStr(m_IdentNr.getTyp) & ";%' " sSQL = sSQL & "and Typenzusatzbereiche like '%;" & CStr(m_IdentNr.getTypzusatz) & ";%' " sSQL = sSQL & "and Temperaturbereiche like '%;" & CStr(m_IdentNr.GetTemperatur) & ";%' " sSQL = sSQL & "and Nennweitenbereiche like '%;" & CStr(m_IdentNr.getNennweite) & ";%';" rs.openRS (sSQL) If Not rs.EOF() Then Else nochmalEingeben: LogIntoDB "kein Datensatz bei " & sSQL, "Daten" GetImpulseLwl = Val(InputBox("Es ist keine Lwl Impulswertigkeit in der Datenbank hinterlegt." & vbCrLf & "Bitte Impulswertigkeit eingeben:")) If GetImpulseLwl = 0 Then GoTo nochmalEingeben End If Exit Function End If ImpulseAnz = rs.getLongValue("LwlPulse_Pro_Anzeige") UmrechnungsFaktor = rs.getDoubleValue("UmrechnungsFaktor") 'AnzeigeEinheitFaktor = rs.getLongValue("AnzeigeEinheitFaktor") m_intAnzahlPaletten = rs.getIntValue("AnzahlPaletten") GetImpulseLwl = ImpulseAnz / UmrechnungsFaktor DebugMsg "LWL ImpulseAnz:" & ImpulseAnz & " / UmrechnungsFaktor: " & UmrechnungsFaktor & " = GetImpulseLwl: " & GetImpulseLwl ' wird nicht benutzt 'DebugMsg "AnzeigeEinheitFaktor :" & AnzeigeEinheitFaktor Set rs = Nothing Exit Function GetImpulseError: Set rs = Nothing ErrorMsg ("CPruefzaehler.GetImpulseLwl Error: " & Err.Description) Exit Function Resume End Function Public Function GetAnzahlPaletten() As Integer If m_intAnzahlPaletten = -1 Then Call GetImpulseQM End If GetAnzahlPaletten = m_intAnzahlPaletten End Function Public Function GetImpulseQM() As Double Dim ANZEIGE As String Dim ImpulseAnz As Double Dim UmrechnungsFaktor As Double Dim AnzeigeEinheitFaktor As Long Dim EinheitID As Integer Dim sSQL As String Dim rs As CRecordset On Error GoTo GetImpulseError ANZEIGE = m_AuftragPosition.getAnzeige ' Nachschlagen von EinheitID über Tabelle Einheit aus AuftragPosition.Anzeige ' --------------------------------------------------------------------------- sSQL = "SELECT EinheitID " sSQL = sSQL & "FROM Einheit where Anzeige = '" & m_AuftragPosition.getAnzeige & "';" Set rs = New CRecordset If Not rs.openRS(sSQL) Then ErrorMsg ("SQL-Fehler bei CPruefzaehler.GetImpulseQM") End If If Not rs.EOF() Then Else ErrorMsg ("Die EinheitID konnte für die Anzeige '" & m_AuftragPosition.getAnzeige & "' nicht ermittelt werden.") Exit Function End If EinheitID = rs.getIntValue("EinheitID") Set rs = Nothing Set rs = New CRecordset sSQL = "SELECT OptoPulse_Pro_Anzeige, UmrechnungsFaktor, AnzeigeEinheitFaktor from IdentNrZaehlwerk where " sSQL = sSQL & "EinheitID = " & EinheitID & " " sSQL = sSQL & "and Typenbereiche like '%;" & CStr(m_IdentNr.getTyp) & ";%' " sSQL = sSQL & "and Typenzusatzbereiche like '%;" & CStr(m_IdentNr.getTypzusatz) & ";%' " sSQL = sSQL & "and Temperaturbereiche like '%;" & CStr(m_IdentNr.GetTemperatur) & ";%' " sSQL = sSQL & "and Nennweitenbereiche like '%;" & CStr(m_IdentNr.getNennweite) & ";%';" rs.openRS (sSQL) If Not rs.EOF() Then Else nochmalEingeben: LogIntoDB "kein Datensatz bei " & sSQL, "Daten" GetImpulseQM = Val(InputBox("Es ist keine Impulswertigkeit in der Datenbank hinterlegt." & vbCrLf & "Bitte Impulswertigkeit eingeben:")) If GetImpulseQM = 0 Then GoTo nochmalEingeben End If Exit Function End If ImpulseAnz = rs.getDoubleValue("OptoPulse_Pro_Anzeige") UmrechnungsFaktor = rs.getDoubleValue("UmrechnungsFaktor") AnzeigeEinheitFaktor = rs.getLongValue("AnzeigeEinheitFaktor") GetImpulseQM = ImpulseAnz / UmrechnungsFaktor DebugMsg "ImpulseAnz:" & ImpulseAnz & " / UmrechnungsFaktor: " & UmrechnungsFaktor & " = GetImpulseQM: " & GetImpulseQM ' wird nicht benutzt 'DebugMsg "AnzeigeEinheitFaktor :" & AnzeigeEinheitFaktor Set rs = Nothing Exit Function GetImpulseError: Set rs = Nothing ErrorMsg ("CPruefzaehler.GetImpulse Error: " & Err.Description) Exit Function Resume End Function Private Sub Class_Initialize() Set m_Prueffehler = New CPrueffehler m_intAnzahlPaletten = -1 End Sub Private Sub loadVorpruefpunkte() Set m_Vorpruefpunkte = New CVorpruefpunkte If Not m_AuftragPosition Is Nothing Then If Not m_Vorpruefpunkte.load(m_AuftragPosition.getIdentNr(), m_sPruefklasseKZ) Then Set m_Vorpruefpunkte = Nothing End If End If End Sub Public Function GetLWLImpulswertigkeit(IdentNrObj As CIdentNr, AuftragPosition As CAuftragPosition) As Long On Error GoTo Errorhandler Dim strTyp As String Dim strTypzusatz As String Dim lngNennweite As Long Dim rs As CRecordset Dim strSQL As String Dim strZulassungskennzeichen As String strTyp = IdentNrObj.getTyp strTypzusatz = IdentNrObj.getTypzusatz lngNennweite = IdentNrObj.getNennweite strZulassungskennzeichen = GetWertFromZusatztext(AuftragPosition.getZusatztext, "Zulassungskennzeichen :") strSQL = "SELECT * from LWL_Impulswertigkeit " strSQL = strSQL & " Where (Typ like '%;" & strTyp & ";%' OR Typ = ';*;') " strSQL = strSQL & " AND (Typzusatz like '%;" & strTypzusatz & ";%' OR Typzusatz = ';*;') " strSQL = strSQL & " AND (Nennweite like '%;" & lngNennweite & ";%' OR Nennweite = ';*;') " strSQL = strSQL & " AND (Zulassungskennzeichen like '%;" & strZulassungskennzeichen & ";%' OR Zulassungskennzeichen = ';*;') " strSQL = strSQL & " AND (Metrolog like '%;" & AuftragPosition.getMetrolog & ";%' OR Metrolog = ';*;') " strSQL = strSQL & " AND (PrfNachMID like '%" & IIf(AuftragPosition.getPrf_nach_MID, "1", "0") & "%' OR PrfNachMID like '%*%') " strSQL = strSQL & " AND (Kundennummern like '%" & AuftragPosition.getKundenNr & "%' OR Kundennummern like '%*%') " strSQL = strSQL & " ORDER BY Sortorder " Set rs = New CRecordset rs.openRS strSQL, True Debug.Print strSQL If rs.EOF Then ' todo nicetohave: Dummy-Datensatz anlegen und benachrichtigen ' rs.addNew ' rs.setValue "Typ", ";" & strTyp & ";" ' rs.setValue "Typzusatz", ";" & strTypZusatz & ";" ' rs.setValue "Nennweite", ";" & lngNennweite & ";" ' rs.setValue "ImpulswertigkeitLWL", 0 ' rs.update GetLWLImpulswertigkeit = 0 Else GetLWLImpulswertigkeit = rs.getLongValue("ImpulswertigkeitLWL") End If Exit Function Errorhandler: GetLWLImpulswertigkeit = 0 LogIntoDB "Fehler " & Err.Number & " in GetLWLImpulswertigkeit(): " & Err.Description, "Softwarefehler" End Function Private Sub SetzeLWLPruefzeiten(Pruefpunkte As CPruefpunktCol, AuftragPosition As CAuftragPosition, IdentNrObj As CIdentNr) On Error GoTo Errorhandler Dim lngIdentNr As Long Dim strMetrolog As String Dim strKurzBez As String Dim strTyp As String Dim strTypzusatz As String Dim lngNennweite As Long Dim blnIsEncoder As Boolean Dim lngTemperatur As Long Dim intPruefpunktanzahl As Integer Dim objBestellcode As CBestellcode Dim strSQL As String Dim strSQL2 As String Dim strVerhaeltnisQ3Q1 As String Dim strZulassungskennzeichen As String Dim rs As CRecordset Dim intPPNr As Integer DebugMsg "SetzeLWLPruefzeiten():" intPruefpunktanzahl = Pruefpunkte.getCollection.Count strMetrolog = AuftragPosition.getMetrolog lngIdentNr = IdentNrObj.getNr strKurzBez = IdentNrObj.GetKurzBezeichnung strTyp = IdentNrObj.getTyp strTypzusatz = IdentNrObj.getTypzusatz lngNennweite = IdentNrObj.getNennweite lngTemperatur = IdentNrObj.GetTemperatur strZulassungskennzeichen = GetWertFromZusatztext(AuftragPosition.getZusatztext, "Zulassungskennzeichen :") If IdentNrObj.GetBestellgruppe > 0 And AuftragPosition.GetBestellcode <> "" Then Set objBestellcode = New CBestellcode objBestellcode.load AuftragPosition.GetBestellcode, IdentNrObj.GetBestellgruppe blnIsEncoder = IsEncoder(objBestellcode) strVerhaeltnisQ3Q1 = objBestellcode.GetWert("Verhaeltnis_Q3_Q1") End If strSQL = "SELECT * from LWL_Pruefzeiten " strSQL = strSQL & " WHERE aktiv=1 " strSQL = strSQL & " AND (IdentNr like '%;" & lngIdentNr & ";%' OR IdentNr = ';*;')" ' If AuftragPosition.getPrf_nach_MID Then ' strSQL = strSQL & " AND (Metrolog like '%;MID%;' OR Metrolog = ';*;') " ' Else strSQL = strSQL & " AND (Metrolog like '%;" & strMetrolog & ";%' OR Metrolog = ';*;') " ' End If If strVerhaeltnisQ3Q1 <> "" Then strSQL = strSQL & " AND (VerhaeltnisQ3Q1 like '%;" & strVerhaeltnisQ3Q1 & ";%' OR VerhaeltnisQ3Q1 = ';*;') " End If strSQL = strSQL & " AND (KurzBez like '%;" & strKurzBez & ";%' OR KurzBez = ';*;') " strSQL = strSQL & " AND (Typ like '%;" & strTyp & ";%' OR Typ = ';*;') " strSQL = strSQL & " AND (Typzusatz like '%;" & strTypzusatz & ";%' OR Typzusatz = ';*;') " strSQL = strSQL & " AND (Nennweite like '%;" & lngNennweite & ";%' OR Nennweite = ';*;') " strSQL = strSQL & " AND (Temperatur like '%;" & lngTemperatur & ";%' OR Temperatur = ';*;') " strSQL = strSQL & " AND (Encoder like '%;" & IIf(blnIsEncoder, "1", "0") & ";%' OR Encoder = ';*;') " strSQL = strSQL & " AND (Zulassungskennzeichen like '%;" & strZulassungskennzeichen & ";%' OR Zulassungskennzeichen = ';*;') " strSQL = strSQL & " ORDER BY Prioritaet" Set rs = New CRecordset rs.openRS strSQL, True DebugMsg strSQL If rs.EOF Then ' es wurde kein aktiver Datensatz gefunden. ' suchen nach einem inaktiven Datensatz strSQL = Replace(strSQL, " aktiv=1 ", " aktiv=0 ") DebugMsg strSQL rs.openRS strSQL, False If rs.EOF Then ' es gibt auch keinen inaktiven Datensatz ' also Dummy Datensatz anlegen rs.addNew rs.setValue "aktiv", 0 rs.setValue "Metrolog", ";" & strMetrolog & ";" rs.setValue "KurzBez", ";" & strKurzBez & ";" rs.setValue "Typ", ";" & strTyp & ";" rs.setValue "Typzusatz", ";" & strTypzusatz & ";" rs.setValue "Nennweite", ";" & lngNennweite & ";" rs.setValue "Encoder", IIf(blnIsEncoder, ";1;", ";0;") rs.setValue "Temperatur", ";" & lngTemperatur & ";" rs.setValue "VerhaeltnisQ3Q1", ";" & strVerhaeltnisQ3Q1 & ";" rs.setValue "Zulassungskennzeichen", ";" & strZulassungskennzeichen & ";" For intPPNr = 1 To intPruefpunktanzahl Debug.Print "PP" & intPPNr rs.setValue "T" & intPPNr, Pruefpunkte.Item(intPPNr).GetTime Next rs.update Dim strMailtext As String Dim varFeld As Variant strMailtext = "LWL Prüfung an Prüfstation " & g_App.PruefstationNr & vbCrLf strMailtext = strMailtext & "Es wurde ein neuer Datensatz in Tabelle LWL_Pruefzeiten eingefügt. Bitte pflegen!" & vbCrLf & vbCrLf strMailtext = strMailtext & "Eigenschaften: " & vbCrLf For Each varFeld In rs.GetRecordsetObject.Fields strMailtext = strMailtext & varFeld.Name & " = " & rs.GetRecordsetObject.Fields(varFeld.Name).value & vbCrLf Next strMailtext = strMailtext & "" & vbCrLf strMailtext = strMailtext & "zugehoerige Datenbank Abfrage:" & vbCrLf strMailtext = strMailtext & "" & strSQL & vbCrLf strMailtext = strMailtext & "" & vbCrLf strMailtext = strMailtext & "Um die LWL Prüfzeiten für diesen Zähler zu ändern, können sie nun die Eigenschaft aktiv=1 setzen." & vbCrLf SendMail "nobody@sensus.com", "peter.buch@sensus.com", "Neuer Datensatz in LWL_Pruefzeiten", strMailtext Else ' es gibt bereits einen inaktiven Datensatz ' hier muss nichts getan werden ' Stattdessen sollten die Prüfpunkte überprüft u. gepflegt und dann aktiv werden End If Else Select Case rs.RecordCount Case 1 'm_lng_LWLImpulswertigkeit = rs.getLongValue("Impulswertigkeit") For intPPNr = 1 To intPruefpunktanzahl Debug.Print "T" & intPPNr & "=" & rs.getLongValue("T" & intPPNr) DebugMsg "T" & intPPNr & "=" & rs.getLongValue("T" & intPPNr) Pruefpunkte.Item(intPPNr).SetTime rs.getLongValue("T" & intPPNr) Next Case Else MsgBox "mehrere passende Datensätze in Tabelle LWL_Pruefzeiten " & vbCrLf & strSQL End Select End If Exit Sub Errorhandler: LogIntoDB "Fehler " & Err.Number & " in SetzeLWLPruefzeiten(): " & Err.Description, "Softwarefehler" Exit Sub Resume End Sub Private Function IsEncoder(objBestellcode As CBestellcode) As Boolean Dim strTemp As String strTemp = objBestellcode.GetWert("Anzeige") If InStr(1, LCase(strTemp), LCase("Encoder")) > 0 Then IsEncoder = True WriteToLog "Zähler wird als Encoder identifiziert, da im Bestellcode 'Encoder' in Anzeige='" & strTemp & "'" End If If InStr(1, LCase(strTemp), LCase("Hybrid")) > 0 Then IsEncoder = True WriteToLog "Zähler wird als Encoder identifiziert, da im Bestellcode 'Hybrid' in Anzeige='" & strTemp & "'" End If If InStr(1, LCase(strTemp), LCase("Electr ")) > 0 Then IsEncoder = True WriteToLog "Zähler wird als Encoder identifiziert, da im Bestellcode 'Electr ' in Anzeige='" & strTemp & "'" End If strTemp = objBestellcode.GetWert("GWZ_NEBENZAEHLER") If InStr(1, LCase(strTemp), LCase("Encoder")) > 0 Then WriteToLog "Zähler wird als Encoder identifiziert, da im Bestellcode 'Encoder' in GWZ_NEBENZAEHLER='" & strTemp & "'" IsEncoder = True End If strTemp = objBestellcode.GetWert("GWZ_WERKE_UND_ANZEIGE") If InStr(1, LCase(strTemp), LCase("Encoder")) > 0 Then WriteToLog "Zähler wird als Encoder identifiziert, da im Bestellcode 'Encoder' in GWZ_WERKE_UND_ANZEIGE='" & strTemp & "'" IsEncoder = True End If strTemp = objBestellcode.GetWert("Modultyp") If InStr(1, LCase(strTemp), LCase("Encoder")) > 0 Then WriteToLog "Zähler wird als Encoder identifiziert, da im Bestellcode 'Encoder' in Modultyp='" & strTemp & "'" IsEncoder = True End If strTemp = objBestellcode.GetWert("Zählwerk") If InStr(1, LCase(strTemp), LCase("Encoder")) > 0 Then WriteToLog "Zähler wird als Encoder identifiziert, da im Bestellcode 'Encoder' in Zählwerk='" & strTemp & "'" IsEncoder = True End If strTemp = objBestellcode.GetWert("Encoder") Select Case LCase(strTemp) Case "1", "ja", "true" WriteToLog "Zähler wird als Encoder identifiziert, da im Bestellcode Encoder=" & strTemp IsEncoder = True Case "0", "nein", "false" WriteToLog "Zähler wird nicht als Encoder identifiziert, da im Bestellcode Encoder=" & strTemp IsEncoder = False Case Else ' keine Angabe End Select m_blnIsEncoder = IsEncoder End Function Private Function GetMetrologFromSpezifikationen(Bestellcode As CBestellcode) As String Dim rs As CRecordset Dim strSQL As String Dim strNennweite As String Dim strTyp As String Dim strTypzusatz As String Dim strCSD As String strTyp = Bestellcode.GetWert("Typ") strTypzusatz = Bestellcode.GetWert("Typzusatz") strCSD = Bestellcode.GetWert("CSD") strNennweite = Bestellcode.GetWert("Nennweite") '1(5): Produktbezeichnung=Meistream '1(5): Typ=MS '2(1): KurzBez=WZ '2(1): MS_Hochgenauigkeit=Plus, Komplettzähler '2(1): Typzusatz=Plus '3(M): Eichkennzeichnung=International (Sensuswerte) '4(19): CSD=CSD 38134-3-SA '4(19): Logo=Sabesp CSD 38134-3-SA '6(B): Nennweite=50 '9(1): Druck=16 '10(F): Baulaenge=270 '11(8): Bohrung=NBR 7669/1982 PN16 '12(1): Temperatur=30 '12(1): Temperaturstufe=kalt '13(A): Zählwerk=D-Werk mech. '14(1): Anzeige=m³ '15(X): Modultyp=kein MODULME strSQL = "SELECT ID, Metrolog from Spezifikationen where (Typ = '" & strTyp & "' or Typ like '%;" & strTyp & ";%' or Typ like ';*;')" If strTypzusatz <> "" Then strSQL = strSQL & " and (Typzusatz = '" & strTypzusatz & "' or Typzusatz like ';" & strTypzusatz & ";' or Typzusatz like '%;*;%')" Else strSQL = strSQL & " and (Typzusatz = '' or Typzusatz like '%;;%' or Typzusatz like '%;*;%' or Typzusatz is NULL)" End If If strNennweite <> "" Then strSQL = strSQL & " and (Nennweite = '" & strNennweite & "' or Nennweite like ';*;%' or Nennweite is null) " End If If strCSD <> "" Then strSQL = strSQL & " and (CSD = '" & strCSD & "' or CSD like '%;" & strCSD & ";%' or CSD like ';*;') " End If If Me.getAuftrag.getKundenNr <> 0 Then strSQL = strSQL & " and (KundenNr = " & Me.getAuftrag.getKundenNr & " or KundenNr is null) " End If Set rs = New CRecordset rs.openRS strSQL, True Debug.Print strSQL If Not rs.EOF Then If rs.RecordCount > 1 Then BenachrichtigeDatenpflege "Es ist mehr als eine (=" & rs.RecordCount & ") passende Metrolog in der Tabelle Spezifikationen vorhanden. Bitte Daten pflegen!" & vbCrLf & strSQL End If GetMetrologFromSpezifikationen = rs.getStringValue("Metrolog") DebugMsg "Es wird die Metrolog '" & GetMetrologFromSpezifikationen & "' aus der Spezifikation " & rs.getLongValue("ID") & " verwendet." End If Exit Function Errorhandler: LogIntoDB "Fehler " & Err.Number & " in GetMetrologFromSpezifikationen(): " & Err.Description, "Softwarefehler" Exit Function Resume End Function Public Function loadForSerienNr_neu(lSerienNr As Long, Optional AuftragNr As Long) As Boolean Dim AuftragpositionSerienNr As CAuftragPositionSerienNr Dim AuftragPosition As CAuftragPosition Dim Auftrag As CAuftrag Dim Pruefpunkte As CPruefpunkte Dim sPruefklasseKZ As String Dim IdentNr As Long Dim IdentNrObj As CIdentNr Dim Bestellcode As CBestellcode Dim VakoCode As CVakoCode Dim Ratio As Double Dim dblNenndurchfluss As Double Dim KZP As CKZP Dim intKZP As Integer m_strPruefpunktInfo = "" Set AuftragpositionSerienNr = loadAuftragPositionSerienNr(lSerienNr, AuftragNr) If AuftragpositionSerienNr Is Nothing Then loadForSerienNr_neu = False Exit Function End If DebugMsg "loadForSerienNr_neu: " & lSerienNr & " aus " & AuftragpositionSerienNr.getAuftragNr & "/" & AuftragpositionSerienNr.getPositionNr ' Auftragsdaten holen ' ------------------- Set AuftragPosition = loadAuftragPositionForSerienNr() If AuftragPosition Is Nothing Then Exit Function End If Set Auftrag = loadAuftrag(AuftragPosition.getAuftragNr()) If Auftrag Is Nothing Then Exit Function End If Set m_Auftrag = Auftrag ' Prüfpunkte laden ' ---------------- Set Pruefpunkte = New CPruefpunkte If AuftragPosition.getMetrolog <> "" Then Debug.Print "Metrolog '" & AuftragPosition.getMetrolog & "' vorhanden " End If ' PruefklasseKZ bestimmen '------------------------ If AuftragPosition.getMetrolog() <> "" Then sPruefklasseKZ = Trim(AuftragPosition.getMetrolog()) Debug.Print "AuftragPosition getMetrolog = '" & sPruefklasseKZ & "'" Else Debug.Print "AuftragPosition.getMetrolog ist leer" End If ' IdentNr laden ' ------------- IdentNr = AuftragPosition.getIdentNr() Set IdentNrObj = loadIdentNr(IdentNr) Debug.Print IdentNrObj.GetBestellgruppe If AuftragPosition.GetBestellcode <> "" And IdentNrObj.GetBestellgruppe <> 0 Then Debug.Print "Bestellcode " & AuftragPosition.GetBestellcode & " auswerten nach Gruppe " & IdentNrObj.GetBestellgruppe Set Bestellcode = New CBestellcode If Bestellcode.load(AuftragPosition.GetBestellcode, IdentNrObj.GetBestellgruppe) Then ' setze Eigenschaften vom Bestellcode ' Metrolog If Bestellcode.GetWert("Metrolog") <> "" Then sPruefklasseKZ = Bestellcode.GetWert("Metrolog") End If If Bestellcode.GetWert("KZP") <> "" Then intKZP = Bestellcode.GetWert("KZP") End If If Bestellcode.GetWert("Nenndurchfluss") > 0 And Bestellcode.GetWert("Nenndurchfluss") > 0 Then ' Nenndurchfluss ' Verhaeltnis_Q3_Q1 (Ratio) ' Prüfpunkte nach MID If Pruefpunkte.CreateMIDPruefpunkteFromBestellcode(Bestellcode) Then ' Prüfpunkte nach MID wurden erzeugt m_strPruefpunktInfo = m_strPruefpunktInfo & "Prf nach MID aus Bestellcode." GoTo DatenSchreiben End If End If End If End If If IdentNrObj.GetVakoCode <> "" Then Set VakoCode = New CVakoCode If VakoCode.load(IdentNrObj.GetVakoCode) Then m_strPruefpunktInfo = "Vakocode " If VakoCode.GetWert("Metrolog") <> "" Then ' Die Metrolog im VakoCode kann in der Auftragposition überschrieben werden ' sPruefklasseKZ = VakoCode.GetWert("Metrolog") ' m_strPruefpunktInfo = m_strPruefpunktInfo & "Metrolog aus Vakocode. " End If If Pruefpunkte.CreateMIDPruefpunkteFromVakoCode(VakoCode) Then m_strPruefpunktInfo = m_strPruefpunktInfo & "Nach MID aus Vakocode." End If End If End If If intKZP > 0 Then Set KZP = New CKZP If KZP.load(intKZP) Then If KZP.getPruefklasseKZ <> "" Then sPruefklasseKZ = KZP.getPruefklasseKZ End If End If End If If sPruefklasseKZ <> "" Then If Pruefpunkte.load(IdentNr, sPruefklasseKZ) Then m_strPruefpunktInfo = m_strPruefpunktInfo & "PP Tabelle aus IdenTnr " & IdentNr & " u. Metrolog '" & sPruefklasseKZ & "'" End If End If DatenSchreiben: If Not Pruefpunkte Is Nothing Then ' Wenn LWL gewählt ist, dann Prüfzeiten aus Tabelle LWL_Pruefzeiten beziehen If g_blnPrfMitLWL = True And Pruefpunkte.getPruefpunkteCount > 0 Then SetzeLWLPruefzeiten Pruefpunkte.getPruefpunkte, AuftragPosition, IdentNrObj m_lng_LWLImpulswertigkeit = GetLWLImpulswertigkeit(IdentNrObj, AuftragPosition) End If End If ' Daten erst jetzt in Member-Variablen schreiben! ' ----------------------------------------------- m_lSerienNr = lSerienNr m_nKZP = AuftragPosition.getKZP m_lIdentNr = AuftragPosition.getIdentNr() m_Bemerkung = AuftragpositionSerienNr.getBemerkung() m_sPruefklasseKZ = sPruefklasseKZ m_strKundeneigeneSerienNr = AuftragpositionSerienNr.getKundeneigeneSerienNr Set m_Auftrag = Auftrag Set m_AuftragPosition = AuftragPosition Set m_IdentNr = IdentNrObj Set m_KZP = KZP Set m_Pruefpunkte = Pruefpunkte LoadForSerienNrOK: loadForSerienNr_neu = True Exit Function loadForSerienNrErr: Call showError("loadForSerienNrErr") Exit Function Resume End Function Public Function IstRueckläufer() As Boolean Dim rs As CRecordset Dim strSQL As String IstRueckläufer = False ' Nachschauen, ob dieser Zähler ein Rückläufer ist strSQL = "SELECT * from Ruecklaeuferanalyse where SerienNr = " & getSerienNr() & " order by ID" Debug.Print strSQL Set rs = New CRecordset rs.openRS strSQL, True If Not rs.EOF Then ' Dieser Zähler ist oder war schon einmal ein Rückläufer ' man muss den letzten Eintrag betrachten, um zu sehen, ob die Reparatur erfolgreich war rs.MoveLast If rs.getBooleanValue("ReparaturErfolgreich") = True Then ' Nachdem die Reparatur erfolgreich war, ist dieser Zähler nun kein Rückläufer mehr. ' Der Vorgang ist abgeschlossen! IstRueckläufer = False Else IstRueckläufer = True End If Else IstRueckläufer = False End If End Function