Attribute VB_Name = "modFunktionspruefung" Option Explicit Private Declare Sub GetSystemTime Lib "kernel32" (lpSystemTime As SYSTEMTIME) Public mdblTemperaturVorgabeVorlauf As Double Public mdblTemperaturVorgabeRuecklauf As Double Public gblnUseFP_FlowSimulation As Boolean Public mdblToleranzEnergie As Double Public mdblToleranzDeltaT As Double Public Type SYSTEMTIME wYear As Integer wMonth As Integer wDayOfWeek As Integer wDay As Integer wHour As Integer wMinute As Integer wSecond As Integer wMilliseconds As Integer End Type Public Type TYPE_MessDaten lngIdentNoForVerification As Long 'Wenn erkannt, dann dieses Platz auch prüfen intPortNr As Integer 'Die COM-Port-Nr dtmStartZeit As Date 'Startzeit der Funktionsprüfung dblStartDeltaT As Double 'Am Start gemessene Temperatur (US-Zähler) ' dblStartVolume As Double 'Am Start gemessenes Volumen (ausgelesen) ' dblStartEnergy As Double 'Am Start gemessene Energie (ausgelesen) dtmStopZeit As Date 'Endzeit der Funktionsprüfung dblStopDeltaT As Double 'Am Ende gemessene Temperatur (US-Zähler) dblStopVolume As Double 'Am Ende gemessenes Volumen (ausgelesen) dblStopEnergy As Double 'Am Ende gemessene Energie (ausgelesen) blnDeltaT_OK As Boolean blnEnergy_OK As Boolean End Type Public Function ExtendedPruefungsInitialisierung(ByVal intPortNr As Integer, Optional ByRef lngIdentNoForVerification As Long = -1) As Long Dim lngReturn As Long lngReturn = PruefungsInitialisierung(intPortNr) If lngReturn = 0 Then lngReturn = SetTemperatureTransferLock(intPortNr, True) If lngReturn = 0 Then lngReturn = NOWA_START(intPortNr) If lngReturn = 0 Then If gblnUseFP_FlowSimulation Then lngReturn = Set_FP_Flow_Simu(intPortNr, 10 / 3600) '= 10 m³/h (wird aber in m³/s übergeben!) If lngReturn = 0 Then lngReturn = Set_special_mode(intPortNr, True) End If End If End If End If End If ExtendedPruefungsInitialisierung = lngReturn End Function Public Function ExtendedPruefungsAbschluss(ByVal intPortNr As Integer, Optional ByRef lngIdentNoForVerification As Long = -1) As Long Dim lngReturn As Long lngReturn = NOWA_STOP(intPortNr) If lngReturn = 0 Then lngReturn = SetTemperatureTransferLock(intPortNr, False, lngIdentNoForVerification) If lngReturn = 0 Then lngReturn = Set_special_mode(intPortNr, False, lngIdentNoForVerification) If lngReturn = 0 Then lngReturn = PruefungsAbschluss(intPortNr) End If End If End If ExtendedPruefungsAbschluss = lngReturn End Function Public Function GetSollEnergy(ByVal dblStopVolume As Double, _ ByVal dblStopEnergy As Double, _ ByVal dblStartDeltaT As Double, _ ByVal dblStopDeltaT As Double, _ ByVal dtmMessDauer As Date) As Double Dim dblDeltaT As Double Dim dblKilogramm As Double Const c = 4187 'J/(kg K) Joule je Kilogramm und Kelvin dblDeltaT = (dblStartDeltaT + dblStopDeltaT) / 2 dblKilogramm = dblStopVolume 'Annahme: 1Liter = 1kg !!!!!!!! ToDo ??? Dim dblSollEnergy As Double Dim dblToleranz As Double dblSollEnergy = dblKilogramm * c * dblDeltaT '[Ws] dblSollEnergy = dblSollEnergy / 1000 '[kWs] dblSollEnergy = dblSollEnergy / 3600 '[kWh] GetSollEnergy = dblSollEnergy End Function Public Function isEnergyOK(ByVal dblStopVolume As Double, _ ByVal dblStopEnergy As Double, _ ByVal dblStartDeltaT As Double, _ ByVal dblStopDeltaT As Double, _ ByVal dtmMessDauer As Date) As Boolean Dim dblDeltaT As Double Dim dblKilogramm As Double Const c = 4187 'J/(kg K) Joule je Kilogramm und Kelvin isEnergyOK = False dblDeltaT = (dblStartDeltaT + dblStopDeltaT) / 2 dblKilogramm = dblStopVolume 'Annahme: 1Liter = 1kg !!!!!!!! ToDo ??? Dim dblSollEnergy As Double Dim dblToleranz As Double dblSollEnergy = dblKilogramm * c * dblDeltaT '[Ws] dblSollEnergy = dblSollEnergy / 1000 '[kWs] dblSollEnergy = dblSollEnergy / 3600 '[kWh] ' RH 22.10.02 Hier tritt der Überlauf wenn mdblSollEnergy = 0 ist dblToleranz = ((dblStopEnergy - dblSollEnergy) / dblSollEnergy) If (Abs(dblToleranz) * 100) <= mdblToleranzEnergie Then isEnergyOK = True End If End Function 'Genauer als Now(), da dieser Wert auch Millisekunden enthält !!! 'Die Zeit ist die GMT-Zeit ! Public Function GetTime() As Date Dim udtSysTime As SYSTEMTIME GetSystemTime udtSysTime With udtSysTime GetTime = DateSerial(.wYear, .wMonth, .wDay) + _ TimeSerial(.wHour, .wMinute, .wSecond) + .wMilliseconds / 86400000 End With End Function Public Function AllDeltaT_OK(mudtMessDaten() As TYPE_MessDaten) As Boolean Dim i As Integer Dim blnOK As Boolean blnOK = True For i = 0 To UBound(mudtMessDaten) If mudtMessDaten(i).intPortNr <> 0 Then If Not DeltaT_Difference_OK(mudtMessDaten(i).intPortNr) Then 'Fehlerabweichung zu groß blnOK = False Debug.Print "Fehlerhafte Temperaturdifferenz bei Einbauplatz " & i Else mudtMessDaten(i).blnDeltaT_OK = True End If End If Next AllDeltaT_OK = blnOK End Function Private Function DeltaT_Difference_OK(ByVal intPortNr As Integer, Optional ByRef lngIdentNoForVerification As Long = -1) As Boolean Dim dblDeltaT_US As Double Dim dblDeltaT_NUDAM As Double DeltaT_Difference_OK = False dblDeltaT_US = DeltaT_US(intPortNr, lngIdentNoForVerification) dblDeltaT_NUDAM = DeltaT_NUDAM() If (Abs(dblDeltaT_US) < 200) And (Abs(dblDeltaT_NUDAM < 200)) Then If Abs(dblDeltaT_US - dblDeltaT_NUDAM) <= mdblToleranzDeltaT Then 'Nur Abweichung < 10 Grad erlaubt DeltaT_Difference_OK = True End If End If End Function Private Function DeltaT_US(ByVal intPortNr As Integer, Optional ByRef lngIdentNoForVerification As Long = -1) As Double DeltaT_US = -9999999 'Bedeutet, das kein richtiger Wert ermittelt wurde Dim dblResult As Double Dim lngReturn As Long lngReturn = Get_T_fp(intPortNr, enuTemp_DeltaVorlaufRuecklauf, dblResult, lngIdentNoForVerification) If lngReturn = 0 Then DeltaT_US = dblResult End Function Private Function DeltaT_NUDAM() As Double DeltaT_NUDAM = 9999999 'Bedeutet, das kein richtiger Wert ermittelt wurde If mdblTemperaturVorgabeVorlauf > 0 And mdblTemperaturVorgabeRuecklauf > 0 Then DeltaT_NUDAM = mdblTemperaturVorgabeVorlauf - mdblTemperaturVorgabeRuecklauf End If End Function Public Function SavePruefergebnis(ByVal lngFabNr As Long, ByVal blnPruefungOK As Boolean) As Boolean On Error GoTo SavePruefergebnis_Error SavePruefergebnis = False Dim strSQL As String strSQL = "SELECT * FROM SpeicherAbbild WHERE FabNr=" & lngFabNr & ";" Dim ADOConnection As ADODB.connection Set ADOConnection = g_App.getDB.getConnection Dim rs As CRecordset Set rs = New CRecordset rs.openRS strSQL, False If rs.EOF Then SavePruefergebnis = False Else If blnPruefungOK Then rs.setValue "FunktionsPruefung", Now() Else rs.setValue "FunktionsPruefung", Null End If rs.update End If Set rs = Nothing SavePruefergebnis = False Exit Function SavePruefergebnis_Error: ErrorMsg "Fehler bei 'SavePruefergebnis': (" & Err.Number & ") " & Err.Description End Function