VERSION 1.0 CLASS BEGIN MultiUse = -1 'True Persistable = 0 'NotPersistable DataBindingBehavior = 0 'vbNone DataSourceBehavior = 0 'vbNone MTSTransactionMode = 0 'NotAnMTSObject END Attribute VB_Name = "CPruefpunkte" 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 : Pruefpunkte.cls ' Author : Andreas Schmidt, Reinhard Henning, lindner & partner ' Date : 14.04.1999 ' Version: 1.01 ' '============================================================================== ' ' Verwaltung einer Menge von Prüfpunkten wie in der Datenbanktabelle ' "Pruefpunkte" hinterlegt. ' ' Die eigentlichen Prüfpunkte werden hier in einem Objekt der Klasse ' CPruefpunktCol verwaltet. ' ' @see CPruefpunktCol ' '============================================================================== ' ' History: ' ' Author : Andreas Schmidt, Reinhard Henning, lindner & partner ' Date : 14.04.1999 ' Version: 1.01 ' ' Sortierung nach dem useCount-Member neu. ' ' Author : Andreas Schmidt, Reinhard Henning, lindner & partner ' Date : 31.03.1999 ' Version: 1.00 ' ' Erste dokumentierte Version ' '============================================================================== Option Explicit ' Private Member ' -------------- Private Const MAX_PP% = 10 Private m_lIdentNr As Long Private m_sPruefklasseKZ As String Private m_Regulierdaten As CRegulierdaten Private m_colPP As CPruefpunktCol Private m_sInfo As String Private m_sFehlerstack As String Public m_lngSpezifikationID As Long Public m_bPruefung_nach_MID As Boolean Public m_dblRatio As Double Public m_Qp As CPruefpunkt Public m_Qi As CPruefpunkt Public mstr_Kundenmaterialnr As String ' Alle Member neu initialisieren ' Private Sub init() m_lIdentNr = 0 m_sPruefklasseKZ = "" 'm_sInfo = "" m_sFehlerstack = "" Set m_colPP = New CPruefpunktCol Set m_Regulierdaten = New CRegulierdaten End Sub Public Function getSpezifikationID() As Long getSpezifikationID = m_lngSpezifikationID End Function ' @return RegulierdatenObject ' Public Function getRegulierdaten() As CRegulierdaten Set getRegulierdaten = m_Regulierdaten End Function Public Sub setRegulierdaten(Regulierdaten As CRegulierdaten) Set m_Regulierdaten = Regulierdaten End Sub ' @return Anzahl der definierten Prüfpunkte (0 bis MAX_PP) ' Public Function getPruefpunkteCount() As Integer If Not m_colPP Is Nothing Then getPruefpunkteCount = m_colPP.Count() End Function ' @return Collection von Objekten der Klasse CPruefpunkt ' Public Function getPruefpunkte() As CPruefpunktCol Set getPruefpunkte = m_colPP End Function ' @param colPP Collection von Objekten der Klasse CPruefpunkt ' Public Sub setPruefpunkte(colPP As CPruefpunktCol) Set m_colPP = colPP End Sub ' @param nIndex Index in die Collection der Prüfpunkte ' ' @return Objekt vom Typ CPuefpunkt an der Stelle nIndex aus ' der Collection der Prüfpunkte ' Public Function getPruefpunkt(nIndex As Integer) As CPruefpunkt Set getPruefpunkt = m_colPP.Item(nIndex) End Function ' @return true = Es gibt einen Pruefpunkt mit dem gesuchten Durchfluss ' Public Function hasQ(dQ As Double) As Boolean If Not m_colPP Is Nothing Then hasQ = m_colPP.hasQ(dQ) End Function Public Sub setIdentNr(lIdentNr As Long) m_lIdentNr = lIdentNr End Sub ' @return Ident-Nr., zu der die Prüfpunkte gehören ' Public Function getIdentNr() As Long getIdentNr = m_lIdentNr End Function Public Sub setPruefklasseKZ(sPruefklasseKZ As String) m_sPruefklasseKZ = sPruefklasseKZ End Sub ' @return Prüfklasse-Kennzeichen (A, B, HM) ' Public Function getPruefklasseKZ() As String getPruefklasseKZ = m_sPruefklasseKZ End Function Public Sub setInfo(sInfo As String) m_sInfo = sInfo End Sub Public Function getInfo() As String getInfo = m_sInfo End Function ' Prüfpunkte zur übergebenen Ident-Nr. und PrüfklasseKZ aus der ' Datenbank laden ' ' @return true = Laden erfolgreich durchgeführt ' Public Function load(ByVal lIdentNr As Long, sPruefklasseKZ As String) As Boolean Dim Pruefpunkt As CPruefpunkt Dim sSQL As String Dim rs As CRecordset Dim i As Integer Dim sNummer As String Dim Pruefzeit As Long Dim sSQL2 As String Dim rs2 As CRecordset On Error GoTo loadErr ' Prüfpunkte ' ---------- Set rs = New CRecordset sSQL = "SELECT * FROM " sSQL = sSQL & "Pruefpunkte " sSQL = sSQL & "WHERE " sSQL = sSQL & "IdentNr = " & lIdentNr & " AND " sSQL = sSQL & "PruefklasseKZ = " & rs.stringToSQLString(sPruefklasseKZ, True) sSQL = sSQL & ";" Set rs2 = New CRecordset sSQL2 = "SELECT * from SollwertRegulierung where " sSQL2 = sSQL2 & "IdentNr = " & lIdentNr & " AND " sSQL2 = sSQL2 & "PruefklasseKZ = " & rs.stringToSQLString(sPruefklasseKZ, True) ' sSQL2 = sSQL2 & " AND PruefstationNr=" & g_App.PruefstationNr If Not rs2.openRS(sSQL2) Then ErrorMsg "Fehler beim Laden der SollwertRegulierdaten: " & Err.Description 'Exit Function End If If rs2.EOF Then Debug.Print sSQL2 If g_App.PruefstationNr <> 24 Then ' #20170801 'ErrorMsg "Es konnten keine SollwertRegulierdaten gefunden werden" & vbCrLf & " für IdentNr=" & lIdentNr & " und sPruefklasseKZ=" & sPruefklasseKZ End If 'Exit Function End If If Not rs.openRS(sSQL) Then If g_App.PruefstationNr <> 24 Then ErrorMsg "DB Fehler beim Laden der Pruefpunkte: " & Err.Description End If End If If rs.EOF Then DebugMsg "Es konnten keine Pruefpunkte geladen werden für " & vbCrLf & "IdentNr=" & lIdentNr & " und PruefklasseKZ=" & sPruefklasseKZ & "." Exit Function End If Call init m_lIdentNr = rs.getLongValue("IdentNr") m_sPruefklasseKZ = rs.getStringValue("PruefklasseKZ") m_sInfo = m_sInfo & rs.getStringValue("Info") & "" m_sFehlerstack = rs.getStringValue("Fehlerstack") DebugMsg "Prüfpunkte für IdentNr " & m_lIdentNr & " und Prüfklasse '" & sPruefklasseKZ & "' aus DB:" For i = 1 To MAX_PP sNummer = Trim(Val(i)) Pruefzeit = 60 If i = MAX_PP Then Pruefzeit = 120 End If If Not rs2.EOF Then Pruefzeit = rs2.getLongValue("P" & sNummer & "SollPruefzeit") Else DebugMsg "Prüfzeit aus DB konnte nicht ermittelt werden" End If If Not rs.isFieldNull("Q" & i) Then Set Pruefpunkt = New CPruefpunkt Call Pruefpunkt.setMember( _ rs.getDoubleValue("Q" & sNummer), _ rs.getDoubleValue("FGo" & sNummer), _ rs.getDoubleValue("FGu" & sNummer), , Pruefzeit) m_colPP.Add Pruefpunkt DebugMsg " " & i & ". Prüfpunkt Q=" & Pruefpunkt.getQ DebugMsg " Prüfzeit: " & Pruefzeit DebugMsg " FGo: " & Pruefpunkt.getFGo DebugMsg " FGu: " & Pruefpunkt.getFGu End If Next i ' Sollwerte ' -------- Call m_Regulierdaten.load(lIdentNr, sPruefklasseKZ) ' Prüfpunkte sortieren Call sortQ load = True Exit Function loadErr: Call showError("load") Exit Function End Function ' Prüfpunkte absteigend nach Durchfluss sortieren ' Public Sub sortQ() If g_blnPruefpunkteUnsortiert = False Then Call m_colPP.sortQ End If End Sub ' Prüfpunkte aufsteigend nach dem useCount-Member sortieren ' Public Sub sortUseCount() Call m_colPP.sortUseCount End Sub '------------------------------------------------------------------------------ ' Private Funktionalität '------------------------------------------------------------------------------ ' Helper für Fehlerausgaben ' ' @param sMethod Name des Aufrufers ' @param sInfo optionaler Hinweistext ' Private Sub showError(sMethod As String, Optional sInfo As String) Call modError.showError("CPruefpunkte." + sMethod, sInfo) End Sub 'Public Function CreateMIDPruefpunkteFromBestellcode(objBestellcode As CBestellcode) As Boolean ' Dim dblNennDurchfluss As Double ' Dim dblNennDurchfluss_heiss As Double ' Dim dblDurchflussQ As Double ' ' Dim strPruefklasse As String ' ' Dim dblVerhaeltnisQ3Q1 As Double ' ' Dim strWert As String ' ' strWert = objBestellcode.GetWert("Verhaeltnis_Q3_Q1") ' ' aus dem Bestellcode kommt dieser Wert mit einem Komma -> in . umwandeln ' strWert = Replace(strWert, ",", ".") ' dblVerhaeltnisQ3Q1 = Val(strWert) ' ' strWert = objBestellcode.GetWert("Nenndurchfluss") ' ' aus dem Bestellcode kommt dieser Wert mit einem Komma -> in . umwandeln ' strWert = Replace(strWert, ",", ".") ' dblNennDurchfluss = Val(strWert) ' ' If dblVerhaeltnisQ3Q1 = 0 Or dblNennDurchfluss = 0 Then ' DebugMsg "Die MID Prüfpunkte konnten nicht aus dem Bestellcode '" & objBestellcode.GetBestellcode & "' (Merkmalgruppe = " & objBestellcode.GetMerkmalgruppe & ") ermittelt werden." ' CreateMIDPruefpunkteFromBestellcode = False ' Exit Function ' End If ' ' ' ' Hier sind Nenndurchfluss und Verhältniss Q3/Q1 über den Bestellcode definiert ' Set m_colPP = New CPruefpunktCol ' ' Dim Pruefpunkt As CPruefpunkt ' ' ' Prüfpunkte des Kaltwasserzählers ' ''''''''''''''''''''''''''''' ' ' Q4 = 1.25 * QN ' dblDurchflussQ = dblNennDurchfluss * 1.25 ' Debug.Print "Q4 = " & dblNennDurchfluss & " {Qn} * " & 1.25 & " {Const} = " & dblDurchflussQ ' ' Set Pruefpunkt = New CPruefpunkt ' Pruefpunkt.setFGo 2 ' Pruefpunkt.setFGu -2 ' Pruefpunkt.setQ Round(dblDurchflussQ, 3) ' Pruefpunkt.SetTime 60 ' m_colPP.Add Pruefpunkt ' ''''''''''''''''''''''''''''' ' ' Q3 ist nur eine rechnerische Größe ' ' und wird nicht geprüft ' ''''''''''''''''''''''''''''' ' Debug.Print "Q3 = Qn = " & dblNennDurchfluss & " (wird nicht geprüft)" ' ' ' Q2 = Q1 * 1.6 ' dblDurchflussQ = 1.6 * dblNennDurchfluss / dblVerhaeltnisQ3Q1 ' Debug.Print "Q2 = 1.6 {Const} * " & dblNennDurchfluss & " {Qn} / " & dblVerhaeltnisQ3Q1 & " {Vq3q1} = " & dblDurchflussQ ' ' Set Pruefpunkt = New CPruefpunkt ' Pruefpunkt.setFGo 2 ' Pruefpunkt.setFGu -2 ' Pruefpunkt.setQ Round(dblDurchflussQ, 3) ' Pruefpunkt.SetTime 60 ' m_colPP.Add Pruefpunkt ' ''''''''''''''''''''''''''''' ' ' Q1 = Qn / VQ3Q1 ' ' dblDurchflussQ = Round(dblNennDurchfluss / dblVerhaeltnisQ3Q1, 3) ' ' Debug.Print "Q1 = " & dblNennDurchfluss & " {Qn} / " & dblVerhaeltnisQ3Q1 & " {Vq3Q1} = " & dblDurchflussQ ' ' Set Pruefpunkt = New CPruefpunkt ' Pruefpunkt.setFGo 5 ' Pruefpunkt.setFGu -5 ' Pruefpunkt.setQ Round(dblDurchflussQ, 3) ' Pruefpunkt.SetTime 120 ' m_colPP.Add Pruefpunkt ' ' ' CreateMIDPruefpunkteFromBestellcode = True 'End Function Public Function CreateMIDPruefpunkteFromBestellcode_NEU1(objBestellcode As CBestellcode, AuftragPosition As CAuftragPosition, objIdentNr As CIdentNr) As Boolean Dim strKurzBez As String Dim strTyp As String Dim strTypzusatz As String Dim lngNennweite As Long Dim lngIdentNr As Long Dim strTemp As String Dim rs As CRecordset Dim strMetrolog As String Dim blnEncoder As Boolean Dim strSQL As String Dim dblNenndurchfluss As Double Dim dblDurchflussQ As Double Dim strPruefklasse As String Dim dblVerhaeltnisQ3Q1 As Double Dim strWert As String ' IdentNr Typ ' Metrolog ' Bestellcode Encoder ' Bestellcode Nennweite lngIdentNr = objIdentNr.getNr strKurzBez = objIdentNr.GetKurzBezeichnung strTyp = objIdentNr.getTyp strTypzusatz = objIdentNr.getTypzusatz strMetrolog = AuftragPosition.getMetrolog strTemp = objBestellcode.GetWert("ANZEIGE") If InStr(1, LCase(strTemp), LCase("Encoder")) > 0 Then blnEncoder = True If InStr(1, LCase(strTemp), LCase("Hybrid")) > 0 Then blnEncoder = True If InStr(1, LCase(strTemp), LCase("Electr ")) > 0 Then blnEncoder = True strTemp = objBestellcode.GetWert("GWZ_NEBENZAEHLER") If InStr(1, LCase(strTemp), LCase("Encoder")) > 0 Then blnEncoder = True strTemp = objBestellcode.GetWert("GWZ_WERKE_UND_ANZEIGE") If InStr(1, LCase(strTemp), LCase("Encoder")) > 0 Then blnEncoder = True strTemp = objBestellcode.GetWert("Modultyp") If InStr(1, LCase(strTemp), LCase("Encoder")) > 0 Then blnEncoder = True strTemp = objBestellcode.GetWert("Zählwerk") If InStr(1, LCase(strTemp), LCase("Encoder")) > 0 Then blnEncoder = True strSQL = "SELECT * from MID_Pruefpunkte where aktiv = 1 " strSQL = strSQL & " AND (IdentNr = '" & lngIdentNr & "' or IdentNr= 0) " strSQL = strSQL & " AND (Kurzbez = '" & strKurzBez & "' or Kurzbez = '*') " strSQL = strSQL & " AND (Kurzbez = '" & strKurzBez & "' or Kurzbez = '*') " strSQL = strSQL & " AND (Typ ='" & strTyp & "' or Typ = '*') " strSQL = strSQL & " AND (Typzusatz = '" & strTypzusatz & "' or Typzusatz = '*' ) " strSQL = strSQL & " AND (Metrolog = '" & strMetrolog & "' or Metrolog = '*' ) " strSQL = strSQL & " AND (Nennweite = " & lngNennweite & ") " strSQL = strSQL & " AND (Encoder = '" & IIf(blnEncoder, 1, 0) & "' or Encoder = '*') " Set rs = New CRecordset rs.openRS strSQL, True '''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''' strWert = objBestellcode.GetWert("Verhaeltnis_Q3_Q1") ' aus dem Bestellcode kommt dieser Wert mit einem Komma -> in . umwandeln strWert = Replace(strWert, ",", ".") dblVerhaeltnisQ3Q1 = Val(strWert) m_dblRatio = dblVerhaeltnisQ3Q1 strWert = objBestellcode.GetWert("Nenndurchfluss") ' aus dem Bestellcode kommt dieser Wert mit einem Komma -> in . umwandeln strWert = Replace(strWert, ",", ".") dblNenndurchfluss = Val(strWert) If dblVerhaeltnisQ3Q1 = 0 Or dblNenndurchfluss = 0 Then DebugMsg "Die MID Prüfpunkte konnten nicht aus dem Bestellcode '" & objBestellcode.GetBestellcode & "' (Merkmalgruppe = " & objBestellcode.GetMerkmalgruppe & ") ermittelt werden." CreateMIDPruefpunkteFromBestellcode_NEU1 = False Exit Function End If m_bPruefung_nach_MID = True ' Hier sind Nenndurchfluss und Verhältniss Q3/Q1 über den Bestellcode definiert Set m_colPP = New CPruefpunktCol Dim Pruefpunkt As CPruefpunkt ' Prüfpunkte des Kaltwasserzählers ''''''''''''''''''''''''''''' ' wird nach OIML R49-1 (2006) nicht geprüft (nur bei Zulassungsprüfungen) ' Q4 = 1.25 * QN 'dblDurchflussQ = dblNennDurchfluss * 1.25 'Debug.Print "Q4 = " & dblNennDurchfluss & " {Qn} * " & 1.25 & " {Const} = " & dblDurchflussQ ''''''''''''''''''''''''''''' ' Q3 ' ''''''''''''''''''''''''''''' dblDurchflussQ = dblNenndurchfluss Debug.Print "Q3 = Qn = " & dblNenndurchfluss Set Pruefpunkt = New CPruefpunkt Pruefpunkt.setQ Round(dblDurchflussQ, 3) If rs.EOF Then Pruefpunkt.setFGo rs.getDoubleValue("FGo1") Pruefpunkt.setFGu rs.getDoubleValue("FGu1") Pruefpunkt.SetTime rs.getDoubleValue("T1") Else Pruefpunkt.setFGo 2 Pruefpunkt.setFGu -2 Pruefpunkt.SetTime 60 End If m_colPP.Add Pruefpunkt ' Q2 = Q1 * 1.6 dblDurchflussQ = 1.6 * dblNenndurchfluss / dblVerhaeltnisQ3Q1 Debug.Print "Q2 = 1.6 {Const} * " & dblNenndurchfluss & " {Qn} / " & dblVerhaeltnisQ3Q1 & " {Vq3q1} = " & dblDurchflussQ Set Pruefpunkt = New CPruefpunkt Pruefpunkt.setQ Round(dblDurchflussQ, 3) If rs.EOF Then Pruefpunkt.setFGo rs.getDoubleValue("FGo2") Pruefpunkt.setFGu rs.getDoubleValue("FGu2") Pruefpunkt.SetTime rs.getDoubleValue("T2") Else Pruefpunkt.setFGo 2 Pruefpunkt.setFGu -2 Pruefpunkt.SetTime 60 End If m_colPP.Add Pruefpunkt ''''''''''''''''''''''''''''' ' Q1 = Qn / VQ3Q1 dblDurchflussQ = Round(dblNenndurchfluss / dblVerhaeltnisQ3Q1, 3) Debug.Print "Q1 = " & dblNenndurchfluss & " {Qn} / " & dblVerhaeltnisQ3Q1 & " {Vq3Q1} = " & dblDurchflussQ Set Pruefpunkt = New CPruefpunkt Pruefpunkt.setQ Round(dblDurchflussQ, 3) If rs.EOF Then Pruefpunkt.setFGo rs.getDoubleValue("FGo2") Pruefpunkt.setFGu rs.getDoubleValue("FGu2") Pruefpunkt.SetTime rs.getDoubleValue("T2") Else Pruefpunkt.setFGo 5 Pruefpunkt.setFGu -5 Pruefpunkt.SetTime 120 End If m_colPP.Add Pruefpunkt ''''''''''''''''''''''''''''' CreateMIDPruefpunkteFromBestellcode_NEU1 = True g_bln_Pruefung_nach_MID = True End Function Public Function CreateMIDPruefpunkteFromBestellcode(objBestellcode As CBestellcode) As Boolean Dim dblNenndurchfluss As Double Dim dblDurchflussQ As Double Dim strPruefklasse As String Dim dblVerhaeltnisQ3Q1 As Double Dim strWert As String strWert = objBestellcode.GetWert("Verhaeltnis_Q3_Q1") ' aus dem Bestellcode kommt dieser Wert mit einem Komma -> in . umwandeln strWert = Replace(strWert, ",", ".") dblVerhaeltnisQ3Q1 = Val(strWert) m_dblRatio = dblVerhaeltnisQ3Q1 strWert = objBestellcode.GetWert("Nenndurchfluss") ' aus dem Bestellcode kommt dieser Wert mit einem Komma -> in . umwandeln strWert = Replace(strWert, ",", ".") dblNenndurchfluss = Val(strWert) If dblVerhaeltnisQ3Q1 = 0 Or dblNenndurchfluss = 0 Then DebugMsg "Die MID Prüfpunkte konnten nicht aus dem Bestellcode '" & objBestellcode.GetBestellcode & "' (Merkmalgruppe = " & objBestellcode.GetMerkmalgruppe & ") ermittelt werden." CreateMIDPruefpunkteFromBestellcode = False Exit Function End If m_bPruefung_nach_MID = True ' Hier sind Nenndurchfluss und Verhältniss Q3/Q1 über den Bestellcode definiert Set m_colPP = New CPruefpunktCol Dim Pruefpunkt As CPruefpunkt ' Prüfpunkte des Kaltwasserzählers ''''''''''''''''''''''''''''' ' wird nach OIML R49-1 (2006) nicht geprüft (nur bei Zulassungsprüfungen) ' Q4 = 1.25 * QN 'dblDurchflussQ = dblNennDurchfluss * 1.25 'Debug.Print "Q4 = " & dblNennDurchfluss & " {Qn} * " & 1.25 & " {Const} = " & dblDurchflussQ ''''''''''''''''''''''''''''' ' Q3 ' ''''''''''''''''''''''''''''' dblDurchflussQ = dblNenndurchfluss Debug.Print "Q3 = Qn = " & dblNenndurchfluss Set Pruefpunkt = New CPruefpunkt If objBestellcode.GetWert("Nennweite") = 125 And objBestellcode.GetWert("Typ") = "MS" Then 'neu 24.4.2012 Sonderregel Fehlergrenzen Prüfpunkte nach MID: Q3, Q2 = ±2 statt ±1.5 wenn Bestellcode.Nennweite=125 DebugMsg "Sonderregel: FG(Q2)=±2 für NW=125 " Pruefpunkt.setFGo 2 Pruefpunkt.setFGu -2 Else ' neu RH 29.9.2011 Pruefpunkt.setFGo 1.5 Pruefpunkt.setFGu -1.5 End If Pruefpunkt.setQ Round(dblDurchflussQ, 3) Pruefpunkt.SetTime 60 m_colPP.Add Pruefpunkt ' Q2 = Q1 * 1.6 dblDurchflussQ = 1.6 * dblNenndurchfluss / dblVerhaeltnisQ3Q1 Debug.Print "Q2 = 1.6 {Const} * " & dblNenndurchfluss & " {Qn} / " & dblVerhaeltnisQ3Q1 & " {Vq3q1} = " & dblDurchflussQ Set Pruefpunkt = New CPruefpunkt If objBestellcode.GetWert("Nennweite") = 125 And objBestellcode.GetWert("Typ") = "MS" Then 'neu 24.4.2012 Sonderregel Fehlergrenzen Prüfpunkte nach MID: Q3, Q2 = ±2 statt ±1.5 wenn Bestellcode.Nennweite=125 DebugMsg "Sonderregel: FG(Q2)=±2 für NW=125 " Pruefpunkt.setFGo 2 Pruefpunkt.setFGu -2 Else ' neu RH 29.9.2011 Pruefpunkt.setFGo 1.5 Pruefpunkt.setFGu -1.5 End If Pruefpunkt.setQ Round(dblDurchflussQ, 3) Pruefpunkt.SetTime 60 m_colPP.Add Pruefpunkt ''''''''''''''''''''''''''''' ' Q1 = Qn / VQ3Q1 dblDurchflussQ = Round(dblNenndurchfluss / dblVerhaeltnisQ3Q1, 3) Debug.Print "Q1 = " & dblNenndurchfluss & " {Qn} / " & dblVerhaeltnisQ3Q1 & " {Vq3Q1} = " & dblDurchflussQ Set Pruefpunkt = New CPruefpunkt ' Pruefpunkt.setFGo 5 ' Pruefpunkt.setFGu -5 ' neu RH 29.9.2011 Pruefpunkt.setFGo 4 Pruefpunkt.setFGu -4 Pruefpunkt.setQ Round(dblDurchflussQ, 3) Pruefpunkt.SetTime 120 m_colPP.Add Pruefpunkt CreateMIDPruefpunkteFromBestellcode = True g_bln_Pruefung_nach_MID = True End Function Private Function FehlerRahmenTrompete(intTrompetenKlasse As Integer, Q As Double, Qp As Double) As Double ' Diese Funktion bestimmt den maximal erlaubten Fehler nach der Trompetenformel ' nach prEN 1434-1:2004 (D)Seite 13, Kapitel 9.2.2.3 Durchflusssensor Select Case intTrompetenKlasse Case 1 FehlerRahmenTrompete = 1 + 0.01 * Qp / Q If FehlerRahmenTrompete > 3.5 Then FehlerRahmenTrompete = 3.5 Case 2 FehlerRahmenTrompete = 2 + 0.02 * Qp / Q If FehlerRahmenTrompete > 5 Then FehlerRahmenTrompete = 5 Case 3 FehlerRahmenTrompete = 3 + 0.05 * Qp / Q If FehlerRahmenTrompete > 5 Then FehlerRahmenTrompete = 5 Case Else End Select End Function ' '' Reinhard Henning am 17.2.2006 '' Diese Funktion setzt die Prüfpunkte (Q,FGo,FGu,Prüfzeit) '' mit Hilfe der Bestellnummer über Nenndurchfluss,VerhältnisQ3Q1 '' Für den Fall, daß VerhältnisQ3Q1 die Klasse enthält, '' lade die Prüfpunkte wie gehabt 'Public Sub CreateFromBestellnummer(sBestellnummer As String, sProdukt As String) 'On Error GoTo Errorhandler ' ' Dim objBestellcode As CBestellcode ' Dim strTemp As String ' Dim pos As Integer ' Dim strPruefklasse As String ' Dim Pruefpunkt As CPruefpunkt ' ' Dim Temperatur As Integer ' Dim dblNennDurchfluss As Double ' Dim dblVerhaeltnisQ3Q1 As Double ' Dim dblFehlergrenze As Double ' Dim intPruefklasse As Integer ' Dim dblDurchflussQ As Double ' ' ' Set objBestellcode = New CBestellcode ' ' 'zum Testen sBestellnummer = "50101DEG1DB11AX" ' 40 1 1.6 ' 'zum Testen sBestellnummer = "50101D111DB11AX" ' A ' ' If Not objBestellcode.Load(sBestellnummer, sProdukt) Then ' ErrorMsg "Der Bestellcode ('" & sBestellnummer & "') konnte nicht (für Produkttyp '" & sProdukt & "') zur Ermittlung der Prüfpunkte ausgewertet werden." ' Exit Sub ' End If ' ' Select Case objBestellcode.GetWert("Produktbezeichnung") ' Case "Meistream" ' ' OK ' Case Else ' ErrorMsg "Die Bestimmung der Prüfpunkte für Zähler des Typs '" & sProdukt & "' aus dem Bestellcode ist nicht implementiert." ' Exit Sub ' End Select ' ' ' Select Case UCase(objBestellcode.GetWert("Metrolog")) ' Case "A", "B", "C" ' ' hier ist eine Metrologische Klasse über den Bestellcode definiert ' strPruefklasse = Trim(objBestellcode.GetWert("Metrolog")) ' ' Debug.Print "Metrolog " & strPruefklasse ' ' If Load(m_lIdentNr, strPruefklasse) = True Then ' ' Es wurden die Prüfpunkte aus der Tabelle 'Pruefpunkte' geladen ' End If ' Exit Sub ' Case "", "1", "2", "3" ' ' dblVerhaeltnisQ3Q1 = objBestellcode.GetWert("VerhältnisQ3Q1_numerisch") ' If dblVerhaeltnisQ3Q1 = 0 Then ' ErrorMsg "Bestellcode Auswertung: VerhaeltnisQ3Q1 (8. Stelle) ist 0 oder leer" ' Exit Sub ' End If ' ' Hier sind Nenndurchfluss ' ' und Verhältniss Q3/Q1 über den Bestellcode definiert ' ' und die Formeln werden herangezogen ' Set m_colPP = New CPruefpunktCol ' ' If Val(objBestellcode.GetWert("Zählerempfindlichkeit_numerisch")) < 130 Then ' ' Kaltwasser: immer 1. Wert nehmen ' dblNennDurchfluss = Val(Split(objBestellcode.GetWert("Nenndurchfluss"), " ")(0)) ' ' If dblNennDurchfluss = 0 Then ' ErrorMsg "Bestellcode Nenndurchfluss ist '" & objBestellcode.GetWert("Nenndurchfluss") & "' nicht auswertbar." ' Exit Sub ' End If ' ' ' Prüfpunkte des Kaltwasserzählers ' ''''''''''''''''''''''''''''' ' ' Q4 = 1.25 * QN ' dblDurchflussQ = dblNennDurchfluss * 1.25 ' Set Pruefpunkt = New CPruefpunkt ' Pruefpunkt.setFGo 2 ' Pruefpunkt.setFGu -2 ' Pruefpunkt.setQ dblDurchflussQ ' Pruefpunkt.SetTime 60 ' m_colPP.Add Pruefpunkt ' ''''''''''''''''''''''''''''' ' ' Q3 ist nur eine rechnerische Größe ' ' und wird nicht geprüft ' ''''''''''''''''''''''''''''' ' ' Q2 = Q1 * 1.6 ' dblDurchflussQ = 1.6 * dblNennDurchfluss / dblVerhaeltnisQ3Q1 ' Set Pruefpunkt = New CPruefpunkt ' Pruefpunkt.setFGo 2 ' Pruefpunkt.setFGu -2 ' Pruefpunkt.setQ dblDurchflussQ ' Pruefpunkt.SetTime 60 ' m_colPP.Add Pruefpunkt ' ''''''''''''''''''''''''''''' ' ' Q1 = Qn / VQ3Q1 ' dblDurchflussQ = dblNennDurchfluss / dblVerhaeltnisQ3Q1 ' Set Pruefpunkt = New CPruefpunkt ' Pruefpunkt.setFGo 5 ' Pruefpunkt.setFGu -5 ' Pruefpunkt.setQ dblDurchflussQ ' Pruefpunkt.SetTime 120 ' m_colPP.Add Pruefpunkt ' Else ' ' Heiswasser ' If UBound(Split(objBestellcode.GetWert("Nenndurchfluss"), "|")) = 0 Then ' ' nur ein Wert vorhanden: 1. Wert nehmen ' dblNennDurchfluss = Val(Split(objBestellcode.GetWert("Nenndurchfluss"), "|")(0)) ' Else ' ' mehr Werte vorhanden: 2. Wert nehmen ' dblNennDurchfluss = Val(Split(objBestellcode.GetWert("Nenndurchfluss"), "|")(1)) ' End If ' If dblNennDurchfluss = 0 Then ' ErrorMsg "Bestellcode Nenndurchfluss ist '" & objBestellcode.GetWert("Nenndurchfluss") & "' nicht auswertbar." ' Exit Sub ' End If ' ' ' Heisswasser Prüfklasse ' intPruefklasse = 3 ' Zur Zeit gibt es noch keine Möglichkeit ' 'die Klasse im Bestellcode zu übertragen, ' 'wenn Feld 8 bereits durch ein VQ3zuQ1 gefüllt ist ' ' ' Prüfpunkte des Heisswasserzählers ' ''''''''''''''''''''''''''''' ' ' Q = QNenn ' dblDurchflussQ = dblNennDurchfluss ' Set Pruefpunkt = New CPruefpunkt ' Pruefpunkt.setFGo FehlerRahmenTrompete(intPruefklasse, dblDurchflussQ, dblNennDurchfluss) ' Pruefpunkt.setFGu -FehlerRahmenTrompete(intPruefklasse, dblDurchflussQ, dblNennDurchfluss) ' Pruefpunkt.setQ dblNennDurchfluss ' Pruefpunkt.SetTime 60 ' m_colPP.Add Pruefpunkt ' ''''''''''''''''''''''''''''' ' ' Qt = QNenn / 10 ' dblDurchflussQ = dblNennDurchfluss / 10 ' Set Pruefpunkt = New CPruefpunkt ' Pruefpunkt.setFGo FehlerRahmenTrompete(intPruefklasse, dblDurchflussQ, dblNennDurchfluss) ' Pruefpunkt.setFGu -FehlerRahmenTrompete(intPruefklasse, dblDurchflussQ, dblNennDurchfluss) ' Pruefpunkt.setQ dblDurchflussQ ' Pruefpunkt.SetTime 60 ' m_colPP.Add Pruefpunkt ' ' ' Qi ' dblDurchflussQ = dblNennDurchfluss / dblVerhaeltnisQ3Q1 ' Set Pruefpunkt = New CPruefpunkt ' Pruefpunkt.setFGo FehlerRahmenTrompete(3, dblNennDurchfluss / dblVerhaeltnisQ3Q1, dblNennDurchfluss) ' Pruefpunkt.setFGu -FehlerRahmenTrompete(3, dblNennDurchfluss / dblVerhaeltnisQ3Q1, dblNennDurchfluss) ' Pruefpunkt.setQ dblDurchflussQ ' Pruefpunkt.SetTime 120 ' m_colPP.Add Pruefpunkt ' End If ' Case Else ' ErrorMsg "Metrolog '" & objBestellcode.GetWert("Metrolog") & "' aus Bestellcode ist unbekannt" ' End Select 'Exit Sub 'Errorhandler: ' ErrorMsg "Fehler " & Err.Number & " in CreateFromBestellnummer('" & sBestellnummer & "','" & sProdukt & "'): " & vbCrLf & Err.Description 'End Sub ' Diese Funktion gibt eine Kopie dieses CPruefpunkte Objektes zurück ' es enthält ein Kopie der Collection mit kopierten Prüfpunkten Public Function GetPruefpunkteKopie() As CPruefpunkte Dim Pruefpunkt As CPruefpunkt Dim newPruefpunkt As CPruefpunkt Dim Regulierdaten As CRegulierdaten Dim newPPCol As CPruefpunktCol Set newPPCol = New CPruefpunktCol Set GetPruefpunkteKopie = New CPruefpunkte GetPruefpunkteKopie.setIdentNr m_lIdentNr GetPruefpunkteKopie.setInfo m_sInfo GetPruefpunkteKopie.setPruefklasseKZ m_sPruefklasseKZ Set Regulierdaten = New CRegulierdaten Regulierdaten.load m_lIdentNr, m_sPruefklasseKZ GetPruefpunkteKopie.setRegulierdaten Regulierdaten For Each Pruefpunkt In m_colPP.getCollection Set newPruefpunkt = New CPruefpunkt newPruefpunkt.copyFrom Pruefpunkt newPPCol.Add newPruefpunkt Next GetPruefpunkteKopie.setPruefpunkte newPPCol End Function Public Function createFromVakoCode(objVakoCode As CVakoCode, AuftragPosition As CAuftragPosition) As Boolean ' Diese Funktion wird immer dann ausgeführt, wenn in der Auftragposition ein VakoCode vorhanden ist ' und dieser durch die Vako_Merkmalswerte ausgewertet werdenn kann ' es soll allgemein durch den VakoCode auf Prüfpunkte geschlossen werden ' Wenn keine Prüfpunkte geladen werden konnten, liefert diese Funktion false zurück Dim Pruefpunkt As CPruefpunkt Dim PPNr As Integer Dim strKurzBez As String Dim strTyp As String Dim strTypzusatz As String Dim intNennweite As Integer Dim intTemperatur As Integer Dim intDruck As Integer Dim intBaulaenge As Integer Dim strMetrolog As String Dim dblQn As Double Dim dblRatio As Double Dim strSQL As String Dim rs As CRecordset Dim strAusführungLand As String Call init Dim dblNenndurchfluss As Double strMetrolog = AuftragPosition.getMetrolog dblRatio = Val(objVakoCode.GetWert("Ratio")) m_dblRatio = dblRatio dblQn = Val(objVakoCode.GetWert("Qn")) If Left(objVakoCode.VakoCode, 3) = "WPV" And Val(objVakoCode.GetWert("Nennweite")) = 150 Then '' Sonderregel: 29.09.2014: für WPV 150 mit A.Beyer entwickelt ' Prüfpunkte grundsätzlich nicht nach MID berechnen sondern dblQn = 0 dblRatio = 0 If InStr(1, objVakoCode.GetWert("Produktfamilie"), "Dynamic") > 0 Then ' Produktfamilie WPV Dynamic => Metrolog sollte eingetragen sein und wird verwendet Debug.Print strMetrolog Else 'Debug.Print objVakoCode.GetWert("SGR") Debug.Print objVakoCode.GetWert("Qn") If Val(objVakoCode.GetWert("Ratio")) > 0 Then ' mit Metrolog = "MID" aus der Prüfpunkte-Tabelle bestimmen strMetrolog = "MID" Else ' Metrolog = "Sensus MID" aus der Prüfpunkte-Tabelle bestimmen ' festgelegt für Sensus Katalogwerte strMetrolog = "Sensus MID" End If End If End If If Left(objVakoCode.VakoCode, 3) = "MTW" Then '' Sonderregel: 30.10.2012: für VakoCode MTW** sollen die Prüfpunkte nicht errechnet werden. dblQn = 0 dblRatio = 0 ElseIf Left(objVakoCode.VakoCode, 3) = "PST" Then ' Sonderbehandlung PST If CreateMIDPruefpunkteFromVakoCodeForPST(objVakoCode) Then createFromVakoCode = True Exit Function End If Else If dblRatio > 0 And dblQn > 0 Then ' Neu 22.2.2017 Neuer Typ WPD VMT ' Neu 12.12.2017 Neuer Typ WPF If Left(objVakoCode.VakoCode, 3) = "WPD" Or Left(objVakoCode.VakoCode, 3) = "WPF" Then If CreateMIDPruefpunkteFromVakoCode_for_WPD_WPF(objVakoCode) Then createFromVakoCode = True Else createFromVakoCode = False End If Exit Function End If If CreateMIDPruefpunkteFromVakoCode(objVakoCode) Then createFromVakoCode = True Exit Function End If End If End If ' Im VAKO_Merkmal Ausfuehrung Land/C_WPD_QAM sollte der Charcode am Anfang des Wertes stehen ' Todo: in Tabelle VAKO_Merkmal wird der Schlüssel "Ausfuehrung" wird doppelt benutzt, ' einmal mit QA_M als numerischer Wert am Anfang und als CSD XXXXXX ab Wort Nr 2 strAusführungLand = Left(objVakoCode.GetWert("Ausfuehrung"), 2) strKurzBez = objVakoCode.GetWert("KurzBez") strTyp = objVakoCode.GetWert("Typ") strTypzusatz = objVakoCode.GetWert("Typzusatz") intNennweite = Val(objVakoCode.GetWert("Nennweite")) intTemperatur = Val(objVakoCode.GetWert("Temperatur")) intDruck = Val(objVakoCode.GetWert("Druck")) intBaulaenge = Val(objVakoCode.GetWert("Baulaenge")) If objVakoCode.GetWert("Metrolog") <> "" And strMetrolog = "" Then ' Die Metrolog aus der Auftragsposition hat Vorrang strMetrolog = objVakoCode.GetWert("Metrolog") End If If Left(objVakoCode.VakoCode, 3) = "MTW" And (strMetrolog = "" Or strMetrolog = "MID") Then m_sInfo = m_sInfo & "Sonderregel MTW ohne Metrolog: keine Berechnung der Prüfpunkte, sondern passende IdentNr mit Metrolog=MID" & vbCrLf ' Sonderregel: 30.10.2012: für VakoCode MTW** sollen die Prüfpunkte nicht errechnet werden. Es soll eine passende IdentNr herausgesucht werden und dann die Metrologische Klasse MID verwendet werden. strMetrolog = "MID" Else 'strMetrolog = objVakoCode.GetWert("Metrolog") 'eigentlich Problematisch: Was ist, wenn in der Auftragposition die Metrolog geändert wurde? (widerspruch zur Metrolog im VakoCode) 'strMetrolog = AuftragPosition.getMetrolog End If 'If strAusführungLand = "01" Then strAusführungLand = "" 'If strAusführungLand = "" And strMetrolog <> "" Then ' Ausführung_land ist leer aber Metrolog ist vorhanden (keine Prüfpunkte nach MID) ' lade die IdentNr aus einer baugleichen Identnr ohne VakoCode ' mit identischen Eigenschaften KurzBez, Typ, NW, Temp, Druck, KundenNr If strMetrolog <> "" Then strSQL = "SELECT * from IdentNr where 1=1" If strKurzBez <> "" Then 'strSQL = strSQL & " AND (KurzBez = '" & strKurzBez & "' or KurzBez is NULL)" strSQL = strSQL & " AND (KurzBez = '" & strKurzBez & "')" End If If strTyp <> "" Then If strTyp = "WPF" Then ' RH 15.1.2018 strTyp = "WPD" End If 'strSQL = strSQL & " AND (Typ = '" & strTyp & "' or Typ is NULL)" 'strSQL = strSQL & " AND (Typ = '" & strTyp & "')" strSQL = strSQL & " AND (Typ like '" & strTyp & "%')" End If If intNennweite <> 0 Then 'strSQL = strSQL & " AND (Nennweite = '" & intNennweite & "' or Nennweite is NULL)" strSQL = strSQL & " AND (Nennweite = '" & intNennweite & "')" End If If intTemperatur <> 0 Then ' Temperaturen gruppieren If intTemperatur = 30 Or intTemperatur = 50 Then strSQL = strSQL & " AND (Temperatur = 30 or Temperatur = 50 or Temperatur is NULL)" ElseIf intTemperatur = 130 Or intTemperatur = 150 Then strSQL = strSQL & " AND (Temperatur = 130 or Temperatur = 150 or Temperatur is NULL)" Else strSQL = strSQL & " AND (Temperatur = '" & intTemperatur & "' or Temperatur is NULL)" End If End If If intDruck <> 0 Then strSQL = strSQL & " AND (Druck = '" & intDruck & "' or Druck is NULL)" End If ' AB 11.1.2011: Baulänge ist nicht relevant für PP ' If intBaulaenge <> 0 Then ' strSQL = strSQL & " AND (Baulaenge = '" & intBaulaenge & "' or Baulaenge is NULL)" ' End If ' Fert_Ort nicht Versuch und auch nicht leer strSQL = strSQL & " AND (Fert_Ort <> 'VS' or Fert_Ort is NULL) " ' ggf. übereinstimmende KundenNr strSQL = strSQL & " AND (Kunde = '" & AuftragPosition.getKundenNr & "' or Kunde is NULL) " ' aber kein Vako!! strSQL = strSQL & " AND (VakoCode = '' or VakoCode is NULL) " 'strSQL = strSQL & " AND (VakoCode = '' or VakoCode is NULL or VakoCode = '" & objVakoCode.VakoCode & "') " Set rs = New CRecordset Debug.Print strSQL 'Clipboard.SetText strSQL rs.openRS strSQL, False If Not rs.EOF Then Dim lngIdentNr As Long lngIdentNr = rs.getLongValue("IdentNr") If load(lngIdentNr, strMetrolog) Then 'MsgBox "Vako Stufe 1: PP werden aus Identnr " & lngIdentNr & " und Metrolog '" & strMetrolog & "' bestimmt." createFromVakoCode = True m_sInfo = m_sInfo & " (Ähnliche IdentNr für " & strKurzBez & " " & strTyp & " DN" & intNennweite & " " & intTemperatur & "°C PN" & intDruck & " " & intBaulaenge & "mm" & vbCrLf m_sInfo = m_sInfo & "Prüfpunkte aus IdentNr= " & lngIdentNr & ", Metrolog='" & strMetrolog & "')" & vbCrLf m_sPruefklasseKZ = strMetrolog m_lIdentNr = lngIdentNr 'Exit Function Else 'BenachrichtigeDatenpflege "Vako (Stufe 1): Prüfpunkte konnten nicht aus Identnr " & lngIdentNr & " & Metrolog '" & strMetrolog & "' bestimmt werden." & vbCrLf & strSQL & vbCrLf & "Auftrag " & AuftragPosition.getAuftragNr & "/" & AuftragPosition.getNr & ",FA " & AuftragPosition.GetFertigungsauftragNr createFromVakoCode = False End If Else ' BenachrichtigeDatenpflege "Vako (Stufe 1): Es wurde keine passende Identnr gefunden: " & strSQL & vbCrLf & "Auftrag " & AuftragPosition.getAuftragNr & "/" & AuftragPosition.getNr & ",FA " & AuftragPosition.GetFertigungsauftragNr createFromVakoCode = False End If End If Dim strAMTNr As String strAMTNr = GetWertFromLangtext(AuftragPosition, "AMT Nr. ") If mstr_Kundenmaterialnr <> "" Then strAMTNr = mstr_Kundenmaterialnr End If strSQL = "SELECT * from Spezifikationen WHERE 1=1 " If strKurzBez <> "" Then strSQL = strSQL & " AND (KurzBez = '" & strKurzBez & "' or KurzBez is NULL)" End If strSQL = strSQL & " AND (Ausfuehrung_Land = '" & strAusführungLand & "') " ''''''or Ausfuehrung_Land is NULL)" ' neu RH 7.5.2012 strSQL = strSQL & " AND (KundenNr = '" & AuftragPosition.getKundenNr & "' or Kunde is NULL) " If strTyp <> "" Then strSQL = strSQL & " AND (Typ = '" & strTyp & "' or Typ is NULL)" End If '''' später: ''''' strSQL = strSQL & " and (Typzusatz = '" & strTypzusatz & "' or Typzusatz like ';" & strTypzusatz & ";' or Typzusatz like '%;*;%' or Typzusatz is NULL)" If intNennweite <> 0 Then strSQL = strSQL & " AND (Nennweite = '" & intNennweite & "' or Nennweite is NULL)" End If If intTemperatur <> 0 Then If intTemperatur = 30 Or intTemperatur = 50 Then strSQL = strSQL & " AND (Temperatur = 30 or Temperatur = 50 or Temperatur is NULL)" ElseIf intTemperatur = 130 Or intTemperatur = 150 Then strSQL = strSQL & " AND (Temperatur = 130 or Temperatur = 150 or Temperatur is NULL)" Else strSQL = strSQL & " AND (Temperatur = '" & intTemperatur & "' or Temperatur is NULL)" End If End If If intDruck <> 0 Then strSQL = strSQL & " AND (Druck = '" & intDruck & "' or Druck is NULL)" End If ' If intBaulaenge <> 0 Then ' strSQL = strSQL & " AND (Baulaenge = '" & intBaulaenge & "' or Baulaenge is NULL)" ' End If If strMetrolog <> "" Then strSQL = strSQL & " AND (Metrolog = '" & strMetrolog & "' or Metrolog is NULL)" End If If AuftragPosition.getIdentNrObj.GetVakoCodeNZ <> "" Then Dim objVako As CVakoCode Dim strMetrologNz As String Set objVako = New CVakoCode If objVako.load(AuftragPosition.getIdentNrObj.GetVakoCodeNZ) Then strMetrologNz = objVako.GetWert("Metrolog") If strMetrologNz <> "" Then strSQL = strSQL & " AND Metrolog_NZ = '" & strMetrologNz & "'" End If End If End If If dblQn > 0 Then strSQL = strSQL & " AND (Qn= '" & dblQn & "' or Qn is NULL)" End If ' RH 27.5.2013 wieder rausgenommen ' ' todo Filtern nach AMT Nr. ' If strAMTNr <> "" Then ' strSQL = strSQL & " AND AM_Art_Nr = '" & strAMTNr & "' " ' End If ' todo Filtern nach Qn, mit_Reed, mit_Opto ? ' filtern nach Spezifikationen mit eingetragenen Prüfpunkten (notwendig z.B. f. FANr 320710) strSQL = strSQL & " AND (Q1 is not NULL)" 'erst mal nach Anlagezeitpunkt sortiert strSQL = strSQL & " ORDER BY Sortorder" Set rs = New CRecordset Debug.Print strSQL rs.openRS strSQL, False If Not rs.EOF Then If rs.RecordCount = 1 Then ' genau einen Fund 'Debug.Assert False WriteToLog "Vako Stufe 2: Prüfpunkte kommen aus Tabelle Spezifikation mit ID= " & rs.getLongValue("id") m_sInfo = m_sInfo & "Vako Stufe 2: Prüfpunkte kommen aus Tabelle Spezifikation mit ID= " & rs.getLongValue("id") ElseIf rs.RecordCount > 1 Then BenachrichtigeDatenpflege "Vako Stufe 2: Es wurden " & rs.RecordCount & " Datensaetze in 'Spezifikationen' gefunden:" & vbCrLf & strSQL & vbCrLf & "Prüfpunkte kommen aus Tabelle Spezifikation mit ID= " & rs.getLongValue("id") & vbCrLf & "Auftrag " & AuftragPosition.getAuftragNr & "/" & AuftragPosition.getNr & ",FA " & AuftragPosition.GetFertigungsauftragNr ' zuviel gefunden End If m_lngSpezifikationID = rs.getLongValue("ID") Set m_colPP = New CPruefpunktCol For PPNr = 1 To 10 If Not rs.isFieldNull("Q" & PPNr) Then 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") m_colPP.Add Pruefpunkt Else Exit For End If Next If Me.getPruefpunkteCount = 0 And strMetrolog <> "" Then ' noch ein Fallback, wenn keine Prüfpunkte in Spezifikationen definiert sind, RH 7.5.2012 If load(AuftragPosition.getIdentNr, strMetrolog) Then WriteToLog "Prüfpunkte aus IdentNr=" & AuftragPosition.getIdentNr & " und Metrolog=" & strMetrolog Else WriteToLog "Es gibt auch keine Prüfpunkte aus IdentNr=" & AuftragPosition.getIdentNr & " und Metrolog=" & strMetrolog End If End If m_Regulierdaten.setSPSSollwertRegulierung rs.getDoubleValue("SPS_Sollwert_Regulierung") createFromVakoCode = True Else 'Debug.Assert False ' nichts gefunden 'BenachrichtigeDatenpflege "Vako Stufe 2: Es wurden keine Datensaetze in 'Spezifikationen' gefunden:" & vbCrLf & strSQL & vbCrLf & vbCrLf & "Auftrag " & AuftragPosition.getAuftragNr & "/" & AuftragPosition.getNr & ",FA " & AuftragPosition.GetFertigungsauftragNr End If If getPruefpunkte.Count = 0 Then ' nichts gefunden createFromVakoCode = False End If m_Regulierdaten.setSteigung 1, 0.7 m_Regulierdaten.setDaempfung 1, 3 m_Regulierdaten.setSteigung 2, 0.1 m_Regulierdaten.setDaempfung 2, 5 m_Regulierdaten.setSteigung 3, 0.05 m_Regulierdaten.setDaempfung 3, 7 End Function Public Function GetWertFromLangtext(AuftragPosition As CAuftragPosition, strName As String) As String Dim varZeile As Variant For Each varZeile In Split(AuftragPosition.getZusatztext, vbCrLf) Debug.Print "Zeile: " & varZeile If Left(varZeile, Len(strName)) = strName Then GetWertFromLangtext = Right(varZeile, Len(varZeile) - Len(strName)) Exit Function End If Next End Function Public Function GetFehlergrenzenOeffnenSchliessen(ByRef FGoOeff As Double, ByRef FGuOeff As Double, ByRef FGoSchl As Double, ByRef FGuSchl As Double) As Boolean Dim strTyp As String Dim strMetrolog As String Dim strNennweite As String Dim strSQL As String Dim rs As CRecordset Dim objIndentNr As CIdentNr Set objIndentNr = New CIdentNr If objIndentNr.load(m_lIdentNr) Then strTyp = objIndentNr.getTyp strNennweite = CStr(objIndentNr.getNennweite) strMetrolog = m_sPruefklasseKZ 'ID 'TypBereich 'MetrologBereich 'NennweiteBereich 'TemperaturBereich 'FgoOeffnen 'FguOeffnen 'FgoSchliessen 'FGuSchliessen 'Reihenfolge 'Bemerkung strSQL = "SELECT * FROM FehlergrenzenVerbundzaehler " strSQL = strSQL & " WHERE (TypBereich like '%;" & objIndentNr.getTyp & ";%' or TypBereich like '%;*;%') " strSQL = strSQL & " AND (NennweiteBereich like '%;" & CStr(objIndentNr.getNennweite) & ";%' or NennweiteBereich like '%;*;%') " strSQL = strSQL & " AND (MetrologBereich like '%;" & m_sPruefklasseKZ & ";%' or MetrologBereich like '%;*;%') " strSQL = strSQL & " AND (TemperaturBereich like '%;" & objIndentNr.GetTemperatur & ";%' or TemperaturBereich like '%;*;%') " strSQL = strSQL & " ORDER BY Reihenfolge " Debug.Print strSQL Set rs = New CRecordset rs.openRS strSQL, True If Not rs.EOF Then FGoOeff = rs.getDoubleValue("FgoOeffnen") FGuOeff = rs.getDoubleValue("FguOeffnen") FGoSchl = rs.getDoubleValue("FgoSchliessen") FGuSchl = rs.getDoubleValue("FGuSchliessen") GetFehlergrenzenOeffnenSchliessen = True Else Debug.Print "keine passenden FehlergrenzenVerbundzaehler : " & strSQL End If Else Debug.Print "IdentNr " & m_lIdentNr & " konnte nicht geladen wewrden." End If End Function Public Function CreatePruefpunkteFromSpezifikationen(Bestellcode As CBestellcode, Auftrag As CAuftrag) As Boolean Dim rs As CRecordset Dim strSQL As String Dim strNennweite As String Dim strTyp As String Dim strTypzusatz As String Dim strCSD As String CreatePruefpunkteFromSpezifikationen = False strTyp = Bestellcode.GetWert("Typ") strTypzusatz = Bestellcode.GetWert("Typzusatz") strCSD = Trim(Bestellcode.GetWert("CSD")) If strCSD = "" Then Exit Function End If 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 * from Spezifikationen where (Typ = '" & strTyp & "' or Typ like '%;" & strTyp & ";%' or Typ like ';*;') " strSQL = strSQL & " and (Typzusatz = '" & strTypzusatz & "' or Typzusatz like ';" & strTypzusatz & ";' or Typzusatz like '%;*;%' or Typzusatz is NULL)" If strNennweite <> "" Then strSQL = strSQL & " and (Nennweite = '" & strNennweite & "' or Nennweite like ';*;%' or Nennweite is null) " End If 'If strCSD <> "" Then ' CSD darf nicht leer sein strSQL = strSQL & " and (CSD = '" & strCSD & "' or CSD like '%;" & strCSD & ";%' or CSD like ';*;') " 'End If If Auftrag.getKundenNr <> 0 Then strSQL = strSQL & " and (KundenNr = " & Auftrag.getKundenNr & " or KundenNr is null) " End If strSQL = strSQL & " and Q1 > 0 " Set rs = New CRecordset rs.openRS strSQL, True Debug.Print strSQL Dim Pruefpunkt As CPruefpunkt If Not rs.EOF Then Set m_colPP = New CPruefpunktCol If rs.RecordCount > 1 Then BenachrichtigeDatenpflege "CreatePruefpunkteFromSpezifikationen(): Es ist mehr als einen (=" & rs.RecordCount & ") Datensatz in der Tabelle Spezifikationen vorhanden. Bitte Daten pflegen!" & vbCrLf & strSQL & vbCrLf & "Auftrag " & Auftrag.getNr End If Dim sNummer As Integer For sNummer = 1 To 10 If rs.isFieldNull("Q" & sNummer) Then Debug.Print "kein Prüfpunkt Q" & sNummer & " in Tabelle Spezifikation, Datensatz mit ID=" & rs.getLongValue("id") Exit For Else CreatePruefpunkteFromSpezifikationen = True m_lngSpezifikationID = rs.getLongValue("ID") Set Pruefpunkt = New CPruefpunkt Call Pruefpunkt.setMember( _ rs.getDoubleValue("Q" & sNummer), _ rs.getDoubleValue("FGo" & sNummer), _ rs.getDoubleValue("FGu" & sNummer), , rs.getDoubleValue("P" & sNummer & "SollPruefZeit")) m_colPP.Add Pruefpunkt End If Next CreatePruefpunkteFromSpezifikationen = True 'MsgBox "Es werden die Prüfpunkte aus der Spezifikation " & m_lngSpezifikationID & " verwendet." End If Exit Function Errorhandler: LogIntoDB "Fehler " & Err.Number & " in CreatePruefpunkteFromSpezifikationen(): " & Err.Description, "Softwarefehler" Exit Function Resume End Function Public Function CreateMIDPruefpunkteFromVakoCode_for_WPD_WPF(objVakoCode As CVakoCode) As Boolean Dim dblNenndurchfluss As Double Dim dblVerhaeltnisQiQp As Double Dim Pruefpunkt As CPruefpunkt ' nach allgemeinen Zählerprüfpunkten Sensus-1-796 WPD FS - Heisswasser m_dblRatio = Val(Replace(objVakoCode.GetWert("Ratio"), ",", ".")) dblNenndurchfluss = Val(Replace(objVakoCode.GetWert("Qn"), ",", ".")) ' VMT ist veraltet! If InStr(1, objVakoCode.GetWert("Produktfamilie"), "VMT") > 0 Or InStr(objVakoCode.GetWert("Produktfamilie"), "FlowSensor") > 0 Or InStr(objVakoCode.GetWert("Typzusatz"), "Flow-Sensor") Then ' Heisswasser dblVerhaeltnisQiQp = 0.6 m_bPruefung_nach_MID = True Else ' alle anderen WPD kaltwasser ?? CreateMIDPruefpunkteFromVakoCode_for_WPD_WPF = False Exit Function End If Set m_colPP = New CPruefpunktCol ' 1. Prüfpunkt ist Qp = Nenndurchfluss Set Pruefpunkt = New CPruefpunkt Pruefpunkt.setQ dblNenndurchfluss If Val(objVakoCode.GetWert("Nennweite")) < 200 Then Pruefpunkt.setFGo 2 Pruefpunkt.setFGu -2 Else Pruefpunkt.setFGo 1.5 Pruefpunkt.setFGu -1.5 End If Pruefpunkt.SetTime 60 m_colPP.Add Pruefpunkt Set m_Qp = Pruefpunkt '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' 2. Prüfpunkt ist Qp / Ratio Set Pruefpunkt = New CPruefpunkt Pruefpunkt.setQ dblNenndurchfluss / m_dblRatio If Val(objVakoCode.GetWert("Nennweite")) < 200 Then Pruefpunkt.setFGo 2.2 Pruefpunkt.setFGu -2.2 Else Select Case m_dblRatio Case 10 Pruefpunkt.setFGo 4 Pruefpunkt.setFGu -3 Case 25 Pruefpunkt.setFGo 2 Pruefpunkt.setFGu -1.5 End Select End If Pruefpunkt.SetTime 120 m_colPP.Add Pruefpunkt '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Select Case m_dblRatio Case 25 ' 3. Prüfpunkt ist Qi= Qp / Ratio / 2.5 Set Pruefpunkt = New CPruefpunkt Pruefpunkt.setQ dblNenndurchfluss / m_dblRatio / 2.5 If Val(objVakoCode.GetWert("Nennweite")) < 200 Then Pruefpunkt.setFGo 2.5 Pruefpunkt.setFGu -2.5 Else Pruefpunkt.setFGo 4 Pruefpunkt.setFGu -3 End If Pruefpunkt.SetTime 120 m_colPP.Add Pruefpunkt Case 10 ' kein 3. Prüfpunkt Case Else End Select Set m_Qi = Pruefpunkt CreateMIDPruefpunkteFromVakoCode_for_WPD_WPF = True End Function Public Function CreateMIDPruefpunkteFromVakoCode(objVakoCode As CVakoCode) As Boolean Dim dblNenndurchfluss As Double Dim dblDurchflussQ As Double Dim strPruefklasse As String Dim dblVerhaeltnisQ3Q1 As Double Dim strWert As String strWert = objVakoCode.GetWert("Ratio") ' aus dem Bestellcode kommt dieser Wert mit einem Komma -> in . umwandeln strWert = Replace(strWert, ",", ".") dblVerhaeltnisQ3Q1 = Val(strWert) m_dblRatio = dblVerhaeltnisQ3Q1 strWert = objVakoCode.GetWert("Qn") ' aus dem Bestellcode kommt dieser Wert mit einem Komma -> in . umwandeln strWert = Replace(strWert, ",", ".") dblNenndurchfluss = Val(strWert) If dblVerhaeltnisQ3Q1 = 0 Or dblNenndurchfluss = 0 Then DebugMsg "Die MID Prüfpunkte konnten nicht aus dem VakoCode '" & objVakoCode.VakoCode & "' ermittelt werden." CreateMIDPruefpunkteFromVakoCode = False Exit Function End If m_bPruefung_nach_MID = True ' Hier sind Nenndurchfluss und Verhältniss Q3/Q1 über den Bestellcode definiert Set m_colPP = New CPruefpunktCol Dim Pruefpunkt As CPruefpunkt ' Prüfpunkte des Kaltwasserzählers ''''''''''''''''''''''''''''' ' wird nach OIML R49-1 (2006) nicht geprüft (nur bei Zulassungsprüfungen) ' Q4 = 1.25 * QN 'dblDurchflussQ = dblNennDurchfluss * 1.25 'Debug.Print "Q4 = " & dblNennDurchfluss & " {Qn} * " & 1.25 & " {Const} = " & dblDurchflussQ ''''''''''''''''''''''''''''' ' Q3 ' ''''''''''''''''''''''''''''' dblDurchflussQ = dblNenndurchfluss Debug.Print "Q3 = Qn = " & dblNenndurchfluss Set Pruefpunkt = New CPruefpunkt If objVakoCode.GetWert("Nennweite") = 125 And objVakoCode.GetWert("Typ") = "MS" Then 'neu 24.4.2012 Sonderregel Fehlergrenzen Prüfpunkte nach MID: Q3, Q2 = ±2 statt ±1.5 wenn Bestellcode.Nennweite=125 DebugMsg "Sonderregel: FG(Q2)=±2 für NW=125 " Pruefpunkt.setFGo 2 Pruefpunkt.setFGu -2 Else ' neu RH 29.9.2011 Pruefpunkt.setFGo 1.5 Pruefpunkt.setFGu -1.5 End If Pruefpunkt.setQ Round(dblDurchflussQ, 3) Pruefpunkt.SetTime 60 m_colPP.Add Pruefpunkt dblDurchflussQ = 1.6 * dblNenndurchfluss / dblVerhaeltnisQ3Q1 Debug.Print "Q2 = 1.6 {Const} * " & dblNenndurchfluss & " {Qn} / " & dblVerhaeltnisQ3Q1 & " {Vq3q1} = " & dblDurchflussQ ' Q2 = Q1 * 1.6 'ToDo Checken von Roland If (objVakoCode.GetWert("Typzusatz") = "Flow-Sensor") Then 'Q2 = Qp *0,1 dblDurchflussQ = 0.1 * dblNenndurchfluss Debug.Print "Q2 = 0.1 {Const} * " & dblNenndurchfluss & " {Qn} = " & dblDurchflussQ End If Set Pruefpunkt = New CPruefpunkt If objVakoCode.GetWert("Nennweite") = 125 And objVakoCode.GetWert("Typ") = "MS" Then 'neu 24.4.2012 Sonderregel Fehlergrenzen Prüfpunkte nach MID: Q3, Q2 = ±2 statt ±1.5 wenn Bestellcode.Nennweite=125 DebugMsg "Sonderregel: FG(Q2)=±2 für NW=125 " Pruefpunkt.setFGo 2 Pruefpunkt.setFGu -2 Else ' neu RH 29.9.2011 Pruefpunkt.setFGo 1.5 Pruefpunkt.setFGu -1.5 End If Pruefpunkt.setQ Round(dblDurchflussQ, 3) Pruefpunkt.SetTime 60 m_colPP.Add Pruefpunkt ''''''''''''''''''''''''''''' ' Q1 = Qn / VQ3Q1 dblDurchflussQ = Round(dblNenndurchfluss / dblVerhaeltnisQ3Q1, 3) Debug.Print "Q1 = " & dblNenndurchfluss & " {Qn} / " & dblVerhaeltnisQ3Q1 & " {Vq3Q1} = " & dblDurchflussQ Set Pruefpunkt = New CPruefpunkt ' Pruefpunkt.setFGo 5 ' Pruefpunkt.setFGu -5 ' neu RH 29.9.2011 Pruefpunkt.setFGo 4 Pruefpunkt.setFGu -4 Pruefpunkt.setQ Round(dblDurchflussQ, 3) Pruefpunkt.SetTime 120 m_colPP.Add Pruefpunkt '''''''''''''''''''''''''''''''''''''''''' 'Sonderlocke für eRegister MS Nennweite 40 (lassen sich nicht mit LWL prüfen) lt. eMail vom 6.12.2016 von Andreas Pfeiffer '''''''''''' 'Hallo Reinhard, 'Bitte behandele diese Prüfung, so dass für egal welches Ratio oder sonstige Sondereinstellungen dieser Zähler immer mit den unten genannte Prüfzeiten bei Q1, Q2 und Q3 geprüft wird, danke. Mit dieser Maßnahme ist erst einmal Druck aus dieser Prüfsituation herausgenommen worden, wissend das die Prüfzeiten sehr hoch sind, aber bei der sehr geringen Stückzahl ist das auf absehbare Zeit zu verkraften. 'Als spätere Änderung dient dann die Optimierung der Auslesung der Werte 4 mal je Sekunde aller eingebauten Zähler, was dir wohl schon von Thomas Q, bzw. Peter B. mitgeteilt worden ist. 'Mit freundlichen Grüßen / Best regards Andreas Pfeiffer If objVakoCode.GetWert("Zählwerk") = "eRegister" And objVakoCode.GetWert("Typ") = "MS" Then If objVakoCode.GetWert("Nennweite") = 40 Then m_colPP.Item(1).SetTime 60 m_colPP.Item(2).SetTime 900 m_colPP.Item(3).SetTime 1440 End If End If '''''''''''''''''''''''''''''''''''''''''' CreateMIDPruefpunkteFromVakoCode = True g_bln_Pruefung_nach_MID = True End Function Public Function CreateMIDPruefpunkteFromVakoCodeForPST(objVakoCode As CVakoCode) As Boolean Dim dblNenndurchfluss As Double Dim dblDurchflussQ As Double Dim strPruefklasse As String Dim dblVerhaeltnisQ3Q1 As Double Dim strWert As String Dim intPruefklasse As Integer If Val(objVakoCode.GetWert("Trompetenklasse")) > 0 Then intPruefklasse = Val(objVakoCode.GetWert("Trompetenklasse")) End If strWert = objVakoCode.GetWert("Ratio") ' aus dem Bestellcode kommt dieser Wert mit einem Komma -> in . umwandeln strWert = Replace(strWert, ",", ".") dblVerhaeltnisQ3Q1 = Val(strWert) m_dblRatio = dblVerhaeltnisQ3Q1 strWert = objVakoCode.GetWert("Qn") ' aus dem Bestellcode kommt dieser Wert mit einem Komma -> in . umwandeln strWert = Replace(strWert, ",", ".") dblNenndurchfluss = Val(strWert) If dblVerhaeltnisQ3Q1 = 0 Or dblNenndurchfluss = 0 Then DebugMsg "Die MID Prüfpunkte konnten nicht aus dem VakoCode '" & objVakoCode.VakoCode & "' ermittelt werden." CreateMIDPruefpunkteFromVakoCodeForPST = False Exit Function End If m_bPruefung_nach_MID = True ' Hier sind Nenndurchfluss und Verhältniss Q3/Q1 über den Bestellcode definiert Set m_colPP = New CPruefpunktCol Dim Pruefpunkt As CPruefpunkt ' Prüfpunkte des Kaltwasserzählers ''''''''''''''''''''''''''''' ' wird nach OIML R49-1 (2006) nicht geprüft (nur bei Zulassungsprüfungen) ' Q4 = 1.25 * QN 'dblDurchflussQ = dblNennDurchfluss * 1.25 'Debug.Print "Q4 = " & dblNennDurchfluss & " {Qn} * " & 1.25 & " {Const} = " & dblDurchflussQ ''''''''''''''''''''''''''''' ' Q3 ' ''''''''''''''''''''''''''''' dblDurchflussQ = dblNenndurchfluss Debug.Print "Q3 = Qn = " & dblNenndurchfluss Set Pruefpunkt = New CPruefpunkt Pruefpunkt.setFGo FehlerRahmenTrompete(intPruefklasse, dblDurchflussQ, dblNenndurchfluss) Pruefpunkt.setFGu -FehlerRahmenTrompete(intPruefklasse, dblDurchflussQ, dblNenndurchfluss) Pruefpunkt.setQ Round(dblDurchflussQ, 3) Pruefpunkt.SetTime getTimeForPP(dblNenndurchfluss, dblDurchflussQ) m_colPP.Add Pruefpunkt Set m_Qp = Pruefpunkt ' Q2 = Q1 / 10 dblDurchflussQ = dblNenndurchfluss / 10 Debug.Print "Q2 = " & dblNenndurchfluss & " {Qp} / 10 = " & dblDurchflussQ Set Pruefpunkt = New CPruefpunkt Pruefpunkt.setFGo FehlerRahmenTrompete(intPruefklasse, dblDurchflussQ, dblNenndurchfluss) Pruefpunkt.setFGu -FehlerRahmenTrompete(intPruefklasse, dblDurchflussQ, dblNenndurchfluss) Pruefpunkt.setQ Round(dblDurchflussQ, 3) Pruefpunkt.SetTime getTimeForPP(dblNenndurchfluss, dblDurchflussQ) m_colPP.Add Pruefpunkt ''''''''''''''''''''''''''''' ' Q1 = Qn / VQ3Q1 dblDurchflussQ = Round(dblNenndurchfluss / dblVerhaeltnisQ3Q1, 3) Debug.Print "Q1 = " & dblNenndurchfluss & " {Qp} / " & dblVerhaeltnisQ3Q1 & " {Ratio} = " & dblDurchflussQ Set Pruefpunkt = New CPruefpunkt Pruefpunkt.setFGo FehlerRahmenTrompete(intPruefklasse, dblDurchflussQ, dblNenndurchfluss) Pruefpunkt.setFGu -FehlerRahmenTrompete(intPruefklasse, dblDurchflussQ, dblNenndurchfluss) Pruefpunkt.setQ Round(dblDurchflussQ, 3) Pruefpunkt.SetTime getTimeForPP(dblNenndurchfluss, dblDurchflussQ) m_colPP.Add Pruefpunkt Set m_Qi = Pruefpunkt Select Case objVakoCode.GetWert("Nennweite") Case 50, 65, 100 m_colPP.getCollection.Item(1).setFGo 1.5 m_colPP.getCollection.Item(1).setFGu -1.5 m_colPP.getCollection.Item(2).setFGo 1.5 m_colPP.getCollection.Item(2).setFGu -1.5 m_colPP.getCollection.Item(3).setFGo 1 m_colPP.getCollection.Item(3).setFGu -1 Case 80 m_colPP.getCollection.Item(1).setFGo 1.5 m_colPP.getCollection.Item(1).setFGu -1.5 m_colPP.getCollection.Item(2).setFGo 1.5 m_colPP.getCollection.Item(2).setFGu -1.5 m_colPP.getCollection.Item(3).setFGo 1.5 m_colPP.getCollection.Item(3).setFGu -1.5 Case Else End Select ''''' If objVakoCode.GetWert("Nennweite") = 65 Then ''''' Auf Wunsch von J.Lippold 06.08.2013: Fehlerrahmen anpassen / Bei DN65 bitte über alle 3 PrüfPunkte auf ±1% einschränken ''''' m_colPP.getCollection.Item(1).setFGo 1 ''''' m_colPP.getCollection.Item(1).setFGu -1 ''''' m_colPP.getCollection.Item(2).setFGo 1 ''''' m_colPP.getCollection.Item(2).setFGu -1 ''''' m_colPP.getCollection.Item(3).setFGo 1 ''''' m_colPP.getCollection.Item(3).setFGu -1 ''''' End If CreateMIDPruefpunkteFromVakoCodeForPST = True g_bln_Pruefung_nach_MID = True End Function Private Function getTimeForPP(Qp As Double, QSoll As Double) As Long ' in sec Select Case Qp Case 15 Select Case QSoll Case 15 getTimeForPP = 120 Case 1.5 getTimeForPP = 600 Case 0.15 getTimeForPP = 920 End Select Case 25 Select Case QSoll Case 25 getTimeForPP = 120 Case 2.5 getTimeForPP = 600 Case 0.25 getTimeForPP = 920 End Select Case 40 Select Case QSoll Case 40 getTimeForPP = 120 Case 4 getTimeForPP = 420 Case 0.4 getTimeForPP = 720 End Select Case 60 Select Case QSoll Case 60 getTimeForPP = 80 Case 6 getTimeForPP = 420 Case 0.6 getTimeForPP = 540 End Select End Select ' If getTimeForPP * QSoll / 3.6 > g_dblVolumenGrosserBehaelter Then ' getTimeForPP = g_dblVolumenGrosserBehaelter * 3.6 / QSoll ' 'MsgBox "Die Prüfzeit für Qsoll=" & QSoll & " wird auf " & getTimeForPP & "s gesenkt, damit das Prüf-Volumen nicht das Behältervlumen übersteigt." ' End If End Function Public Function GetQp() As CPruefpunkt Set GetQp = m_Qp End Function Public Function GetQi() As CPruefpunkt Set GetQi = m_Qi End Function