VERSION 5.00 Begin VB.Form frmManuellePruefung BorderStyle = 5 'Änderbares Werkzeugfenster Caption = "FM85 Durchflußmessung" ClientHeight = 11340 ClientLeft = 5115 ClientTop = 1710 ClientWidth = 9105 LinkTopic = "Form1" MaxButton = 0 'False MinButton = 0 'False ScaleHeight = 11370.48 ScaleMode = 0 'Benutzerdefiniert ScaleWidth = 9255 ShowInTaskbar = 0 'False Begin VB.Frame Frame1 BackColor = &H8000000A& Caption = "SPS" Height = 2415 Index = 1 Left = 0 TabIndex = 28 Top = 0 Width = 9105 Begin VB.Frame Frame4 Caption = "FU/Servo Stellung" Height = 2055 Left = 6900 TabIndex = 48 Top = 240 Width = 1995 Begin VB.CheckBox chkImmerSpeichern Caption = "immer speichern" Height = 225 Left = 210 TabIndex = 56 Top = 1680 Width = 1455 End Begin VB.CommandButton cmdVoreinstellwertSpeichern Caption = "speichern" Height = 315 Left = 840 TabIndex = 55 Top = 1320 Width = 915 End Begin VB.ComboBox cmbTyp Height = 315 Left = 540 TabIndex = 53 Top = 270 Width = 1245 End Begin VB.ComboBox cmbNennweite Height = 315 Left = 540 TabIndex = 51 Top = 630 Width = 1245 End Begin VB.TextBox txtServo Alignment = 2 'Zentriert BackColor = &H00FFFFFF& Height = 300 Left = 210 TabIndex = 49 Top = 1320 Width = 540 End Begin VB.Label Label12 Caption = "Typ" Height = 285 Left = 90 TabIndex = 54 Top = 300 Width = 525 End Begin VB.Label Label2 Caption = "NW" Height = 285 Left = 150 TabIndex = 52 Top = 690 Width = 555 End Begin VB.Label Label30 Alignment = 2 'Zentriert Caption = "Servo Stellung" BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 240 Left = 60 TabIndex = 50 Top = 1020 Width = 1515 End End Begin VB.TextBox txtQ Alignment = 1 'Rechts BeginProperty Font Name = "MS Sans Serif" Size = 13.5 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 465 Left = 1215 TabIndex = 31 Text = " " Top = 360 Width = 1365 End Begin VB.CommandButton cmdStartSPS Caption = "START" Enabled = 0 'False BeginProperty Font Name = "MS Sans Serif" Size = 13.5 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 705 Left = 1170 TabIndex = 30 Top = 1020 Width = 1515 End Begin VB.CommandButton cmdStopSPS Caption = "STOP" Enabled = 0 'False BeginProperty Font Name = "MS Sans Serif" Size = 13.5 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 705 Left = 3240 TabIndex = 29 Top = 1050 Width = 1515 End Begin VB.Label Label27 Caption = "°C" BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 315 Left = 6270 TabIndex = 42 Top = 1950 Width = 495 End Begin VB.Label lblTemp Alignment = 1 'Rechts BorderStyle = 1 'Fest Einfach Caption = "123,123" BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 375 Left = 5130 TabIndex = 41 Top = 1890 Width = 975 End Begin VB.Label Label28 Alignment = 1 'Rechts Caption = "Vorlauftemp." BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 315 Left = 3570 TabIndex = 40 Top = 1920 Width = 1455 End Begin VB.Label Label24 Caption = "bar" BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 315 Left = 2760 TabIndex = 39 Top = 1920 Width = 495 End Begin VB.Label lblWasserdruck Alignment = 1 'Rechts BorderStyle = 1 'Fest Einfach Caption = "123,123" BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 375 Left = 1680 TabIndex = 38 Top = 1920 Width = 975 End Begin VB.Label Label26 Alignment = 1 'Rechts Caption = "Wasserdruck" BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 315 Left = 120 TabIndex = 37 Top = 1920 Width = 1455 End Begin VB.Label Label33 Alignment = 1 'Rechts Caption = "Q Soll" BeginProperty Font Name = "MS Sans Serif" Size = 13.5 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 480 Left = 120 TabIndex = 36 Top = 360 Width = 1020 End Begin VB.Label Label32 Alignment = 1 'Rechts Caption = "Q ist" BeginProperty Font Name = "MS Sans Serif" Size = 13.5 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 480 Left = 3900 TabIndex = 35 Top = 360 Width = 780 End Begin VB.Label lblQist Alignment = 1 'Rechts BackColor = &H00C0FFFF& BorderStyle = 1 'Fest Einfach Caption = "120,0106" BeginProperty Font Name = "MS Sans Serif" Size = 13.5 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 435 Left = 4740 TabIndex = 34 Top = 360 Width = 1365 End Begin VB.Label Label23 Caption = "m³/h" BeginProperty Font Name = "MS Sans Serif" Size = 13.5 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 480 Left = 6180 TabIndex = 33 Top = 360 Width = 780 End Begin VB.Label Label22 Caption = "m³/h" BeginProperty Font Name = "MS Sans Serif" Size = 13.5 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 480 Left = 2640 TabIndex = 32 Top = 360 Width = 780 End End Begin VB.Frame Frame3 Height = 5280 Left = 0 TabIndex = 18 Top = 5760 Width = 9075 Begin VB.CommandButton cmdTabelleOpen Caption = "öffnen" Height = 225 Left = 7920 TabIndex = 47 ToolTipText = "Öffnen mit Excel" Top = 4830 Width = 735 End Begin VB.TextBox txtLogTabelle Height = 285 Left = 1440 TabIndex = 46 Top = 4770 Width = 6105 End Begin VB.CheckBox chkWriteForExcel Caption = "Log Tabelle" Height = 255 Left = 210 TabIndex = 45 Top = 4770 Width = 1260 End Begin VB.TextBox txtLogfile Height = 285 Left = 1425 TabIndex = 22 Top = 4410 Width = 6105 End Begin VB.CheckBox chkLogFile Caption = "write log to" Height = 255 Left = 240 TabIndex = 21 Top = 4440 Value = 1 'Aktiviert Width = 1260 End Begin VB.CommandButton cmdFileOpen Caption = "öffnen" Height = 225 Left = 7920 TabIndex = 20 Top = 4440 Width = 735 End Begin VB.TextBox txtStatus Height = 4080 Left = 120 MultiLine = -1 'True ScrollBars = 2 'Vertikal TabIndex = 19 Top = 240 Width = 8850 End End Begin VB.PictureBox StatusBar1 Align = 2 'Unten ausrichten Height = 285 Left = 0 ScaleHeight = 225 ScaleWidth = 9045 TabIndex = 5 Top = 11055 Width = 9105 End Begin VB.Frame Frame2 Caption = "FM85 / Referenzzähler" Height = 3135 Left = 0 TabIndex = 0 Top = 2520 Width = 9105 Begin VB.ComboBox cmbEinbauplatzFM85 Height = 315 Left = 4440 TabIndex = 43 Top = 360 Width = 1095 End Begin VB.Timer Timer1 Left = 4200 Top = 1680 End Begin VB.TextBox txtZeit Alignment = 1 'Rechts BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 405 Left = 480 TabIndex = 6 Top = 1680 Width = 1365 End Begin VB.CommandButton cmdFM85Stop Caption = "STOP" Enabled = 0 'False BeginProperty Font Name = "MS Sans Serif" Size = 13.5 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 705 Left = 4800 TabIndex = 4 Top = 1080 Width = 1470 End Begin VB.CommandButton cmdFM85Start Caption = "START" Enabled = 0 'False BeginProperty Font Name = "MS Sans Serif" Size = 13.5 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 705 Left = 2640 TabIndex = 3 Top = 1110 Width = 1470 End Begin VB.Label Label1 Alignment = 1 'Rechts Caption = "FM 85 Nr." BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 360 Left = 3120 TabIndex = 44 Top = 360 Width = 1275 End Begin VB.Label Label5 Caption = "sek." BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 405 Left = 1920 TabIndex = 27 Top = 1680 Width = 540 End Begin VB.Label Label3 Alignment = 2 'Zentriert Caption = "Soll-Prüfzeit" BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 315 Left = 480 TabIndex = 26 Top = 1320 Width = 1425 End Begin VB.Label Label18 Caption = "sek." BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 360 Left = 8400 TabIndex = 25 Top = 1680 Width = 540 End Begin VB.Label Label17 Alignment = 2 'Zentriert Caption = "Ist-Prüfzeit" BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 315 Left = 6960 TabIndex = 24 Top = 1320 Width = 1425 End Begin VB.Label lblTime Alignment = 1 'Rechts BorderStyle = 1 'Fest Einfach Caption = "123,123" BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 405 Left = 6960 TabIndex = 23 Top = 1680 Width = 1365 End Begin VB.Label Liter Caption = "Liter" BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 360 Left = 5160 TabIndex = 17 Top = 2640 Width = 720 End Begin VB.Label Label11 Caption = "m³/h" BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 360 Left = 1920 TabIndex = 16 Top = 2640 Width = 720 End Begin VB.Label Label10 Alignment = 2 'Zentriert Caption = "Impulse" BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 360 Left = 6960 TabIndex = 15 Top = 2280 Width = 1335 End Begin VB.Label lblImpulse Alignment = 1 'Rechts BorderStyle = 1 'Fest Einfach Caption = "12345" BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 375 Left = 6960 TabIndex = 14 Top = 2640 Width = 1335 End Begin VB.Label Label9 Alignment = 2 'Zentriert Caption = "Durchfluss" BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 360 Left = 480 TabIndex = 13 Top = 2280 Width = 1395 End Begin VB.Label Label8 Alignment = 2 'Zentriert Caption = "Volumen" BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 360 Left = 3720 TabIndex = 12 Top = 2280 Width = 1275 End Begin VB.Label lblRZ_Durchfluss Alignment = 1 'Rechts BorderStyle = 1 'Fest Einfach Caption = "123,123" BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 375 Left = 480 TabIndex = 11 Top = 2640 Width = 1335 End Begin VB.Label lblRZVolume Alignment = 1 'Rechts BorderStyle = 1 'Fest Einfach Caption = "12345,123" BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 375 Left = 3720 TabIndex = 10 Top = 2640 Width = 1335 End Begin VB.Label Label6 Caption = "%" BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 360 Left = 8400 TabIndex = 9 Top = 720 Width = 330 End Begin VB.Label Label7 Caption = "Referenzzähler-Fehler" BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 360 Left = 6360 TabIndex = 8 Top = 360 Width = 2640 End Begin VB.Label lblFehlerRZ Alignment = 1 'Rechts BorderStyle = 1 'Fest Einfach BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 405 Left = 6960 TabIndex = 7 Top = 720 Width = 1320 End Begin VB.Label Label4 Alignment = 2 'Zentriert Caption = "Referenzzähler DN" BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 360 Left = 120 TabIndex = 2 Top = 360 Width = 2295 End Begin VB.Label lblNennweite Alignment = 2 'Zentriert BorderStyle = 1 'Fest Einfach BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 405 Left = 480 TabIndex = 1 Top = 720 Width = 1290 End End End Attribute VB_Name = "frmManuellePruefung" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option Explicit Private m_SPS As CSPS Private m_FMBus As CFMBus Private m_DurchflussSoll As Double Private m_ColPumpen As Collection Private m_Referenzzaehler As CRefzaehler Private m_Pumpe As CPumpe Private m_lngmillisec As Long Private m_EinbauplatzNr As Integer Private m_Sollzeit_s As Long Private m_blnPruefungLaeuft As Boolean Private m_fso As FileSystemObject Private m_strFormatVol As String Private mstrZeile(30) As String Private Enum Spalte DatumZeit = 1 Q = 2 Vol = 3 Zeit = 4 RefZFehler = 5 VolKor = 6 Druck = 7 TempStart = 8 TempEnd = 9 ' RefZFehler = 6 ' VolKor = 9 ' Druck = 13 ' TempStart = 14 ' TempEnd = 15 End Enum 'todo: Qsoll begrenzen auf ODurchfluss Private Sub LogZeile() Dim i As Integer Dim strZeile As String For i = 1 To UBound(mstrZeile) strZeile = strZeile & mstrZeile(i) & vbTab mstrZeile(i) = "" Next If Trim(txtLogTabelle.text) = "" Then Exit Sub LogZeileIntoFile strZeile, txtLogTabelle.text End Sub Private Sub LogZeileIntoFile(strZeile As String, strFile As String) On Error Resume Next Dim LogFileHandle As Long LogFileHandle = FreeFile() Open strFile For Append As LogFileHandle Print #LogFileHandle, strZeile Close #LogFileHandle End Sub Private Sub cmdUpdateQ_Click() m_DurchflussSoll = Val(Replace(txtQ.text, ",", ".")) If Not g_ohneSPS Then m_SPS.SetQSoll m_DurchflussSoll End If PrintStatus "Solldurchfluss: " & m_DurchflussSoll & " m³/h" End Sub Private Sub chkWriteForExcel_Click() If chkWriteForExcel.value = vbChecked Then mstrZeile(Spalte.DatumZeit) = "Datum/Uhrzeit" mstrZeile(Spalte.Q) = "Durchfluss (Start)" mstrZeile(Spalte.Vol) = "Volumen I" mstrZeile(Spalte.Zeit) = "Zeit" mstrZeile(Spalte.RefZFehler) = "Ref.z.-fehler" mstrZeile(Spalte.VolKor) = "V korrigiert" mstrZeile(Spalte.Druck) = "Wasserdruck" mstrZeile(Spalte.TempStart) = "Temp.Start" mstrZeile(Spalte.TempEnd) = "Temp.Stop" LogZeile End If End Sub Private Sub cmdTabelleOpen_Click() ExecuteAndWait "notepad.exe ", txtLogTabelle.text, , , False End Sub Private Sub Timer1_Timer() If Not g_ohneSPS Then lblQIst.Caption = Format(m_SPS.getQIst, "0.0000") UpdateTemperatur False If m_SPS.SolldurchflussErreicht Then lblQIst.BackColor = vbGreen Else lblQIst.BackColor = vbYellow End If End If If m_blnPruefungLaeuft Then Dim dblTime_s As Double If m_lngmillisec > 0 Then dblTime_s = (GetTickCount() - m_lngmillisec) / 1000 lblTime.Caption = Format(dblTime_s, "0.000") If m_Sollzeit_s > 0 Then If m_Sollzeit_s - dblTime_s < 0 Then Call cmdFM85Stop_Click txtZeit.text = m_Sollzeit_s End If End If End If End If g_dblWasserdruck = Round(MesseWasserdruck(), 3) If g_dblWasserdruck <> -1 Then lblWasserdruck = g_dblWasserdruck Else lblWasserdruck.Caption = "" End If End Sub Private Function CreateFilename(strFileName As String) CreateFilename = "C:\Genesis Testergebnisse LA\" & Trim(txtQ.text) & "_" & Format(Now, "yyyy-mm-dd_hh-nn-ss") & ".txt" If Not m_fso.FolderExists(m_fso.GetParentFolderName(CreateFilename)) Then m_fso.CreateFolder (m_fso.GetParentFolderName(CreateFilename)) End If End Function Private Function CreateFilenameTabelle(strFileName As String) CreateFilenameTabelle = "C:\Genesis Testergebnisse LA\Tabelle_" & Format(Now, "yyyy-mm-dd_hh-nn-ss") & ".txt" If Not m_fso.FolderExists(m_fso.GetParentFolderName(CreateFilenameTabelle)) Then m_fso.CreateFolder (m_fso.GetParentFolderName(CreateFilenameTabelle)) End If End Function Private Sub cmdFM85Start_Click() cmdFM85Start.Enabled = False Me.MousePointer = vbHourglass If Trim(txtLogfile.text) = "" Then txtLogfile.text = CreateFilename(txtLogfile.text) End If PrintStatus "Referenzzähler NW: " & lblNennweite.Caption PrintStatus "Referenzzähler Fehler: " & Format(lblFehlerRZ.Caption, "0.000") & "%" mstrZeile(Spalte.DatumZeit) = Format(Now, "yyyy.mm.dd hh:mm") mstrZeile(Spalte.RefZFehler) = Format(lblFehlerRZ.Caption, "0.000") mstrZeile(Spalte.Q) = Format(m_DurchflussSoll, "0.000") ClearLbl m_lngmillisec = GetTickCount() UpdateTemperatur True Set m_FMBus = g_App.getFMBus m_EinbauplatzNr = Val(cmbEinbauplatzFM85.text) Set m_Referenzzaehler = New CRefzaehler If m_Referenzzaehler.loadForDurchfluss(m_DurchflussSoll, g_App.Settings.getMIDGruppe) = False Then MsgBox "Kein Referenzzähler für Durchfluss " & m_DurchflussSoll & " definiert. Bitte korrekten Durchfluss angeben!" txtQ.SetFocus GoTo Fertig End If PrintStatus "Impulswertigkeit RZ: " & m_Referenzzaehler.ImpulseQM & " Imp/m³" m_FMBus.send "**" & m_EinbauplatzNr & "@" If m_FMBus.receive(500) = "" Then PrintStatus "FM85 an Einbauplatz " & m_EinbauplatzNr & ": keine Antwort" GoTo Fertig End If ' Nach Empfang dieses Befehls zählt FM85.P alle Impulse des Referenz-Zählers m_FMBus.send "O" m_lngmillisec = GetTickCount() PrintStatus "Referenzzähler Volumen-Messung gestartet" Fertig: If Val(txtZeit.text) > 0 Then m_Sollzeit_s = Val(txtZeit.text) Else m_Sollzeit_s = 0 End If g_dblWasserdruck = Round(MesseWasserdruck(), 3) If g_dblWasserdruck <> -1 Then lblWasserdruck = g_dblWasserdruck PrintStatus "Wasserdruck: " & g_dblWasserdruck & " bar" mstrZeile(Spalte.Druck) = Format(g_dblWasserdruck, "0.000000") End If If Not g_ohneSPS Then txtServo.text = m_SPS.GetStellwert PrintStatus "Stellwert (ist) : " & txtServo.text PrintStatus "Durchfluss (START): " & Format(m_SPS.getQIst, "0.0000") & " m³/h" mstrZeile(Spalte.Q) = Format(m_SPS.getQIst, "0.0000") mstrZeile(Spalte.TempStart) = Format(m_SPS.GetEinlaufTemperatur(), "0.0") End If m_blnPruefungLaeuft = True Me.MousePointer = vbNormal cmdFM85Start.Enabled = True cmdFM85Stop.Enabled = True End Sub Function GetRZVolumen(EinbauplatzNr As Integer, Referenzzaehler As CRefzaehler, ByRef dblVolumen As Double) As Integer Dim FMBus As CFMBus Dim Impulse As Long Dim strTemp As String On Error GoTo GetRZVolumenFehler Impulse = 0 Set FMBus = g_App.getFMBus dblVolumen = 0 FMBus.send "**" & EinbauplatzNr & "@" If FMBus.receive(500) = "" Then GetRZVolumen = -1 Exit Function End If ' Korrektur: 22.2.2013 RH: "l" statt "L" ' Korrektur: 14.5.2013 RH: "L" statt "l" ' Der FM85.P sendet den Wert der bei Erhalt des Befehles L bzw. q zwischengespeicherten Anzahl eingetroffener Impulse des Referenz-Zählers (HEX-Zahl). FMBus.send "L" strTemp = FMBus.receive(500) If strTemp = "" Then GetRZVolumen = -2 Exit Function End If Impulse = CLng("&H0" & strTemp) 'And (2 ^ 31 - 1) lblImpulse.Caption = Impulse dblVolumen = Impulse / Referenzzaehler.ImpulseQM ' in m^3 WriteToLog "Antwort vom FM85-" & EinbauplatzNr & " : '" & strTemp & "'. " & Impulse & " Impulse / " & Referenzzaehler.ImpulseQM & " Impulse/m³ = " & dblVolumen & " m³" Exit Function GetRZVolumenFehler: GetRZVolumen = -99 End Function Private Sub cmdFM85Stop_Click() cmdFM85Stop.Enabled = False Me.MousePointer = vbHourglass m_blnPruefungLaeuft = False Dim dblRefZVolumen As Double Dim intTemp As Integer Dim lngZeit As Long Dim dblFehler As Double Dim Temperatur As Double Dim strFormat As String ' FM adressieren 'Set m_FMBus = g_App.getFMBus() 'm_FMBus.send "**" & m_EinbauplatzNr & "@" 'm_FMBus.receive (500) ' Impulse zwischenspeichern und Zeit Stoppen 'm_FMBus.send "q" 'Debug.Print m_FMBus.receive(500) lngZeit = GetTickCount - m_lngmillisec PrintStatus "Referenzzähler Volumen-Messung gestoppt: " If GetRZVolumen(Val(cmbEinbauplatzFM85.text), m_Referenzzaehler, dblRefZVolumen) = 0 Then PrintStatus "Prüfzeit : " & Round(lngZeit / 1000, 3) & " sek." mstrZeile(Spalte.Zeit) = Format(Round(lngZeit / 1000, 3), "0.###") ' kein Fehler PrintStatus "RefZVolumen (unkorrigiert) = " & Format(dblRefZVolumen * 1000, m_strFormatVol) & " Liter" mstrZeile(Spalte.Vol) = Format(dblRefZVolumen * 1000, m_strFormatVol) If Not g_ohneSPS Then UpdateTemperatur True If Not g_ohneSPS Then mstrZeile(Spalte.TempEnd) = Format(m_SPS.GetEinlaufTemperatur(), "0.0") End If End If ' ' Wasserdruck messen für Zulassungspruefdaten ' g_dblWasserdruck = Round(MesseWasserdruck(), 3) ' If g_dblWasserdruck <> -1 Then ' PrintStatus "Wasserdruck: " & g_dblWasserdruck ' End If dblFehler = m_Referenzzaehler.letzterFehler(m_DurchflussSoll, Temperatur) ' PrintStatus "Fehler RZ =" & Round(dblFehler, 4) & "%" dblRefZVolumen = dblRefZVolumen / (1 + dblFehler / 100) PrintStatus "RefZVolumen (mit RZ Fehler korrigiert) = " & Format(dblRefZVolumen * 1000, m_strFormatVol) & " Liter" lblRZVolume.Caption = Format(dblRefZVolumen * 1000, m_strFormatVol) mstrZeile(Spalte.VolKor) = Format(dblRefZVolumen * 1000, m_strFormatVol) lblTime.Caption = Round(lngZeit / 1000, 3) lblRZ_Durchfluss.Caption = Format(3600 * dblRefZVolumen / (lngZeit / 1000), "0.000") Else PrintStatus "RefZVolumen konnte nicht ermittelt werden." End If PrintStatus "Referenzzähler Volumen-Messung beendet" If chkWriteForExcel.value = vbChecked Then LogZeile End If Fertig: cmdFM85Stop.Enabled = True Me.MousePointer = vbNormal End Sub Private Sub cmdStartSPS_Click() cmdStartSPS.Enabled = False cmdStopSPS.Enabled = True txtLogfile.text = "" txtStatus.text = "" lblFehlerRZ.Caption = "" ClearLbl Me.MousePointer = vbHourglass startSPS Timer1.Interval = 100 Timer1.Enabled = True cmdFM85Start.Enabled = True Me.MousePointer = vbNormal End Sub Private Function initSPSfuerPP() ' SPS für diesen Prüfpunkt initialisieren, unabhängig von Waage/Behälter oder Durchlauf ' ------------------------------------------------------------------------------------- ' Betrieb stoppen und Pumpen Abwählen ' Durchfluß vorgabe ' Pumpe auswählen und anwählen ' Regelart und Regel-Position setzen ' MID Strang setzen Dim i As Integer Dim iStellwert As Integer Dim AnzahlPP As Integer ' Betrieb Start zurücksetzen m_SPS.setBetrieb 8 Sleep 500 m_SPS.setBetrieb 0 PrintStatus "*********************" m_SPS.SetQSoll m_DurchflussSoll PrintStatus "Nächster Durchfluss: " & m_DurchflussSoll ' Pumpenauswahl ' Hochbehälter Auswahl wenn Q < 1 m ^3 -> Pumpe.Nr = 4 ' siehe modPumpe m_SPS.AllePumpenAbwaehlen Set m_Pumpe = Pumpenwahl(m_DurchflussSoll, m_ColPumpen) PrintStatus "zu startende Pumpe: " & m_Pumpe.GetSPSVarname m_Pumpe.Anwahl Select Case m_Pumpe.GetRegelart Case "Servo" ' Servo vorgeschrieben m_SPS.SetRegelart ("Servo") iStellwert = Val(txtServo.text) Case "FU" ' Frequenzumrichter vorgeschrieben m_SPS.SetRegelart ("FU") ' Formel für ServoPosition zur Feinregulierung des Durchflusses iStellwert = Val(txtServo.text) Case Else ErrorMsg "Es ist keine Regelart für die Pumpe " & m_Pumpe.getNr & " in der ini-Datei definiert." Exit Function End Select If iStellwert > 100 Then iStellwert = 100 PrintStatus "Stellwert (soll): " & iStellwert m_SPS.SetServoStellung iStellwert ' Vorwahl Referenzzaehler m_SPS.SetMID m_Referenzzaehler.EinbauplatzNr m_SPS.SetQDiff 0 End Function Private Sub UpdateTemperatur(blnLog As Boolean) Dim Temperatur As Double If Not g_ohneSPS Then Temperatur = m_SPS.GetEinlaufTemperatur() End If lblTemp.Caption = Round(Temperatur, 1) If blnLog Then PrintStatus "Vorlauftemperatur: " & Round(Temperatur, 1) & "°C" End If End Sub Private Sub startSPS() Dim dblLetzterFehler As Double Dim Pumpe As CPumpe Dim Temperatur As Double m_DurchflussSoll = Val(Replace(txtQ.text, ",", ".")) ' "," ist Dezimaltrenner ' todo Prüfbereitschaft testen Set m_Referenzzaehler = New CRefzaehler If m_Referenzzaehler.loadForDurchfluss(m_DurchflussSoll, g_App.Settings.getMIDGruppe) Then lblNennweite.Caption = m_Referenzzaehler.Nennweite PrintStatus "Referenzzähler NW: " & lblNennweite.Caption Select Case m_Referenzzaehler.Nennweite Case 1, 2, 4 m_strFormatVol = "0.0000" Case 8 m_strFormatVol = "0.000" Case Else m_strFormatVol = "0.0" End Select Else PrintStatus "Für den Durchfluss " & m_DurchflussSoll & " ist kein Referenzzähler definiert. Abbruch." MsgBox "Für den Durchfluss " & m_DurchflussSoll & " ist kein Referenzzähler definiert." Exit Sub End If dblLetzterFehler = m_Referenzzaehler.letzterFehler(m_DurchflussSoll, Temperatur) lblFehlerRZ.Caption = Format(dblLetzterFehler, "0.000") PrintStatus "Referenzzähler Fehler: " & Format(dblLetzterFehler, "0.000") & "%" If Not g_ohneSPS Then m_SPS.setBehaelter 1 ' Durchlauf initSPSfuerPP m_SPS.setBetrieb 2 WarteBisSollDurchflussErreicht txtServo.text = m_SPS.GetStellwert PrintStatus "Stellwert (ist) : " & txtServo.text If chkImmerSpeichern.value = vbChecked Then cmdVoreinstellwertSpeichern_Click End If End If End Sub Private Sub WarteBisSollDurchflussErreicht() If g_ohneSPS Then Exit Sub lblQIst.BackColor = vbYellow Do While Not m_SPS.SolldurchflussErreicht lblQIst.Caption = Format(m_SPS.getQIst, "0.0000") Sleep 1000, True Loop lblQIst.BackColor = vbGreen End Sub Private Sub cmdStopSPS_Click() cmdStopSPS.Enabled = False If Not g_ohneSPS Then m_SPS.SetQSoll 0 m_SPS.AllePumpenAbwaehlen m_SPS.setBetrieb 0 End If Timer1.Enabled = False cmdStartSPS.Enabled = True End Sub Private Sub Form_Activate() Me.Width = 9255 Me.Height = 11670 txtQ.text = "" txtQ.SetFocus ClearLbl End Sub Private Sub ClearLbl() lblImpulse.Caption = "" lblQIst.Caption = "" lblRZ_Durchfluss.Caption = "" lblRZVolume.Caption = "" lblTime.Caption = "" lblWasserdruck.Caption = "" lblTemp.Caption = "" End Sub Private Sub Form_Load() Set m_SPS = g_App.getSPS Set m_ColPumpen = g_App.Settings.getPumpen Set m_fso = New FileSystemObject If Not g_ohneSPS Then m_SPS.SetQSoll 0 m_SPS.AllePumpenAbwaehlen m_SPS.setBetrieb 0 End If ClearLbl cmbEinbauplatzFM85.Clear cmbEinbauplatzFM85.AddItem "1" cmbEinbauplatzFM85.ListIndex = cmbEinbauplatzFM85.ListCount - 1 cmbEinbauplatzFM85.AddItem "2" cmbEinbauplatzFM85.AddItem "3" cmbEinbauplatzFM85.AddItem "4" cmbEinbauplatzFM85.AddItem "5" cmbEinbauplatzFM85.AddItem "5" cmbEinbauplatzFM85.AddItem "6" cmbEinbauplatzFM85.AddItem "7" cmbEinbauplatzFM85.AddItem "8" cmbEinbauplatzFM85.AddItem "9" cmbEinbauplatzFM85.AddItem "10" If Trim(txtLogTabelle.text) = "" Then txtLogTabelle.text = CreateFilenameTabelle(txtLogTabelle.text) End If If chkWriteForExcel.value = vbChecked Then chkWriteForExcel_Click End If FillCmbNennweite FillcmbTyp cmbNennweite.text = "50" cmbTyp.text = "Genesis" txtZeit.text = "120" m_strFormatVol = "0.000" End Sub Private Sub Form_Resize() On Error Resume Next Frame1(1).Top = 0 Frame1(1).Left = 0 Frame1(1).Height = Me.ScaleHeight / 4 Frame1(1).Width = Me.ScaleWidth Frame2.Top = Frame1(1).Top + Frame1(1).Height Frame2.Width = Me.ScaleWidth Frame3.Left = 0 Frame3.Top = Frame2.Top + Frame2.Height Frame3.Height = Me.ScaleHeight - Frame1(1).Height - Frame2.Height - StatusBar1.Height Frame3.Width = Me.ScaleWidth Debug.Print "Me.Width= " & Me.Width Debug.Print "Me.Height= " & Me.Height End Sub Private Sub Timer3_Timer() End Sub Private Sub txtQ_Change() UpdateVoreinstellwert End Sub Private Sub txtQ_GotFocus() txtQ.SelStart = 0 txtQ.SelLength = Len(txtQ.text) End Sub Private Sub txtQ_KeyPress(KeyAscii As Integer) ' Wir möchten im Textfeld das , als Dezimaltrenner Debug.Print KeyAscii Select Case KeyAscii Case 44, 46 ' aus . wird KeyAscii = 44 If InStr(1, txtQ.text, ",") > 0 Then KeyAscii = 0 PrintStatus "In deisem Eingabefeld ist nur ein Komma erlaubt." End If Case 48, 49, 50, 51, 52, 53, 54, 55, 56, 57 ' Ziffern 0-9 Case 8, 3, 22, 24, 13 ' BS Case Else PrintStatus "Eingabe von '" & Chr(KeyAscii) & "' nicht möglich" KeyAscii = 0 End Select End Sub Private Sub PrintStatus(strText As String) Debug.Print strText If txtLogfile.text <> "" And chkLogFile.value = vbChecked Then AppendTextToFile Format(Now, "yyyy-mm-dd hh:mm:ss") & vbTab & strText & vbCrLf, txtLogfile.text txtStatus.text = txtStatus.text & strText & vbCrLf Else txtStatus.text = txtStatus.text & " " & strText & vbCrLf End If txtStatus.SelStart = Len(txtStatus.text) txtStatus.SelLength = 0 DoEvents End Sub Private Sub AppendTextToFile(strText As String, strFileName As String) Dim fso As scripting.FileSystemObject Dim ts As scripting.TextStream Set fso = New FileSystemObject Set ts = fso.OpenTextFile(strFileName, ForAppending, True, TristateUseDefault) ts.Write strText ts.Close End Sub Private Sub cmdFileOpen_Click() ExecuteAndWait "notepad.exe ", txtLogfile.text, , , False End Sub Private Sub txtQ_KeyUp(KeyCode As Integer, Shift As Integer) If IsNumeric(txtQ.text) Then Dim dblQ As Double dblQ = CDbl(txtQ.text) If dblQ > 0 Then cmdStartSPS.Enabled = True cmdStartSPS.Default = True Else cmdStartSPS.Enabled = False cmdStartSPS.Default = False End If Else cmdStartSPS.Enabled = False cmdStartSPS.Default = False End If End Sub Private Sub FillCmbNennweite(Optional strTyp As String = "") Dim strSQL As String Dim rs As CRecordset Set rs = New CRecordset cmbNennweite.Clear cmbNennweite.text = "wählen!" strSQL = "select distinct Nennweite from Voreinstellwerte where Nennweite > 0 and Pruefstation = " & g_App.PruefstationNr & " order by Nennweite" rs.openRS strSQL Do While Not rs.EOF cmbNennweite.AddItem rs.getIntValue("Nennweite") rs.MoveNext Loop End Sub Private Sub FillcmbTyp() Dim strSQL As String Dim rs As CRecordset Set rs = New CRecordset cmbTyp.Clear cmbTyp.text = "wählen!" strSQL = "select distinct Typ from Voreinstellwerte where Nennweite > 0 and Pruefstation = " & g_App.PruefstationNr & " order by Typ" rs.openRS strSQL Do While Not rs.EOF cmbTyp.AddItem rs.getStringValue("Typ") rs.MoveNext Loop End Sub Private Sub cmbTyp_Change() UpdateVoreinstellwert End Sub Private Sub cmbTyp_Click() cmbTyp_Change End Sub Private Sub cmbNennweite_Change() UpdateVoreinstellwert End Sub Private Sub cmbNennweite_Click() cmbNennweite_Change End Sub Private Sub UpdateVoreinstellwert() Dim lngNW As Long Dim strTyp As String Dim dblQ As Double lngNW = Val(cmbNennweite.text) dblQ = Val(Replace(txtQ.text, ",", ".")) strTyp = Trim(cmbTyp.text) If lngNW > 0 And dblQ > 0 And strTyp <> "" Then txtServo.text = getVoreinstellwert(dblQ, strTyp, Val(cmbNennweite.text)) End If End Sub Private Function getVoreinstellwert(dblDurchfluss As Double, strTyp As String, lngNW As Long) As Integer Dim strSQL As String Dim rs As CRecordset strSQL = "SELECT * FROM Voreinstellwerte where Durchfluss = " & doubleToSQLString(dblDurchfluss) & " and Nennweite = " & lngNW & " and Pruefstation= " & g_App.PruefstationNr & " and Typ = '" & strTyp & "'" Set rs = New CRecordset rs.openRS strSQL, True If Not rs.EOF Then getVoreinstellwert = rs.getDoubleValue("Voreinstellwert") Else getVoreinstellwert = 50 End If If getVoreinstellwert > 100 Then getVoreinstellwert = 100 Exit Function Errorhandler: PrintStatus "Fehler " & Err.Number & " in GetVoreinstellwert: " & Err.Description End Function Private Sub cmdVoreinstellwertSpeichern_Click() Dim lngNW As Long Dim strTyp As String Dim dblQ As Double Dim intVoreinstellwert As Integer lngNW = Val(cmbNennweite.text) dblQ = Val(Replace(txtQ.text, ",", ".")) strTyp = Trim(cmbTyp.text) intVoreinstellwert = Val(txtServo.text) If lngNW > 0 And dblQ > 0 And strTyp <> "" And Trim(txtServo.text) <> "" Then SaveVoreinstellwert dblQ, strTyp, lngNW, intVoreinstellwert PrintStatus "Voreinstellwert Servo = " & intVoreinstellwert & " wurde gespeichert" Else PrintStatus "Zum Speichern des FU/Servo-Wertes bitte alle Angaben auswählen." End If End Sub Private Sub SaveVoreinstellwert(dblDurchfluss As Double, strTyp As String, lngNW As Long, intVoreinstellwert As Integer) Dim strSQL As String Dim rs As CRecordset strSQL = "SELECT * FROM Voreinstellwerte where Durchfluss = " & doubleToSQLString(dblDurchfluss) & " and Nennweite = " & lngNW & " and Pruefstation= " & g_App.PruefstationNr & " and Typ = '" & strTyp & "'" Set rs = New CRecordset rs.openRS strSQL, False If rs.EOF Then rs.addNew End If rs.setValue "Pruefstation", g_App.PruefstationNr rs.setValue "Nennweite", lngNW rs.setValue "Durchfluss", dblDurchfluss rs.setValue "Typ", strTyp rs.setValue "Voreinstellwert", intVoreinstellwert rs.setValue "Mitarbeiter", g_App.Mitarbeiter.getNr rs.setValue "LetzteAenderung", Now rs.update 'Pruefstation Nennweite Durchfluss Typ Voreinstellwert LetzteAenderung Mitarbeiter rowguid '2006 200 100 Ultraschall 24 2013-06-06 17:06:47.000 7630 3FA463A3-9B51-45EE-BFD1-35489DF27586 Exit Sub Errorhandler: PrintStatus "Fehler " & Err.Number & " in SaveVoreinstellwert: " & Err.Description End Sub