VERSION 5.00 Begin VB.Form USPruefzaehlerPruefung BackColor = &H8000000A& BorderStyle = 0 'Kein Caption = "Pruef2000" ClientHeight = 11520 ClientLeft = 105 ClientTop = 105 ClientWidth = 15360 HelpContextID = 1 Icon = "USPruefzaehlerPruefung.frx":0000 LinkTopic = "Form1" Moveable = 0 'False ScaleHeight = 11520 ScaleWidth = 15360 ShowInTaskbar = 0 'False StartUpPosition = 1 'Fenstermitte WindowState = 2 'Maximiert Begin VB.Frame frMain BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 11475 Left = -30 TabIndex = 4 Top = -180 Width = 14655 Begin VB.CommandButton cmdJustagewerte Caption = "Justage" Enabled = 0 'False Height = 255 Index = 10 Left = 5820 TabIndex = 148 Top = 10230 Visible = 0 'False Width = 825 End Begin VB.CommandButton cmdJustagewerte Caption = "Justage" Enabled = 0 'False Height = 255 Index = 9 Left = 5790 TabIndex = 147 Top = 9240 Visible = 0 'False Width = 825 End Begin VB.CommandButton cmdJustagewerte Caption = "Justage" Enabled = 0 'False Height = 255 Index = 8 Left = 5790 TabIndex = 146 Top = 8160 Visible = 0 'False Width = 825 End Begin VB.CommandButton cmdJustagewerte Caption = "Justage" Enabled = 0 'False Height = 255 Index = 7 Left = 5790 TabIndex = 145 Top = 7170 Visible = 0 'False Width = 825 End Begin VB.CommandButton cmdJustagewerte Caption = "Justage" Enabled = 0 'False Height = 255 Index = 6 Left = 5790 TabIndex = 144 Top = 6090 Visible = 0 'False Width = 825 End Begin VB.CommandButton cmdJustagewerte Caption = "Justage" Enabled = 0 'False Height = 255 Index = 5 Left = 5790 TabIndex = 143 Top = 5070 Visible = 0 'False Width = 825 End Begin VB.CommandButton cmdJustagewerte Caption = "Justage" Enabled = 0 'False Height = 255 Index = 4 Left = 5820 TabIndex = 142 Top = 4080 Visible = 0 'False Width = 795 End Begin VB.CommandButton cmdJustagewerte Caption = "Justage" Enabled = 0 'False Height = 255 Index = 3 Left = 5820 TabIndex = 141 Top = 3060 Visible = 0 'False Width = 795 End Begin VB.CommandButton cmdJustagewerte Caption = "Justage" Enabled = 0 'False Height = 255 Index = 2 Left = 5820 TabIndex = 140 Top = 2100 Visible = 0 'False Width = 795 End Begin VB.CommandButton cmdJustagewerte Caption = "Justage" Enabled = 0 'False Height = 255 Index = 1 Left = 5820 TabIndex = 138 Top = 1050 Visible = 0 'False Width = 795 End Begin VB.Frame frmPruefprotokollDrucken Caption = "Prüfprotokoll" Height = 735 Left = 11400 TabIndex = 133 Top = 9300 Width = 2715 Begin VB.CheckBox chkProtokolldruck Caption = "Protokoll drucken" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 435 Left = 180 TabIndex = 134 ToolTipText = "Aktivieren Sie diese Checkbox, um nach der Prüfung ein Protokoll zu drucken." Top = 180 Width = 2355 End End Begin VB.Frame Frame6 Caption = "Seriennr.-Erkennung" Height = 1845 Left = 6720 TabIndex = 96 Top = 930 Width = 4635 Begin VB.CommandButton cmdStopScan Caption = "STOP SCAN" Height = 255 Left = 3360 TabIndex = 136 Top = 1440 Width = 1095 End Begin VB.Frame frmScanner Caption = "Scanner Eingabe" Height = 1095 Left = 210 TabIndex = 119 Top = 600 Width = 2985 Begin VB.TextBox txtScanner BeginProperty Font Name = "MS Sans Serif" Size = 13.5 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 405 Left = 120 MaxLength = 9 TabIndex = 120 Top = 600 Width = 1575 End Begin VB.Label lblScanner BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 120 TabIndex = 121 Top = 240 Width = 1575 End End Begin VB.CheckBox chkAuto Caption = "Automatik" Height = 225 Left = 3150 TabIndex = 102 Top = 270 Width = 1095 End Begin VB.TextBox txtAnzahl Alignment = 1 'Rechts Height = 315 Left = 2520 MaxLength = 1 TabIndex = 97 Top = 240 Width = 435 End Begin VB.Label lblScanStat BackStyle = 0 'Transparent Caption = "X" Height = 285 Left = 3900 TabIndex = 101 Top = 1020 Width = 255 End Begin VB.Shape Shape1 BackColor = &H000080FF& BackStyle = 1 'Undurchsichtig FillColor = &H00FFFFFF& Height = 375 Left = 3660 Shape = 3 'Kreis Top = 930 Width = 615 End Begin VB.Label Label3 Alignment = 1 'Rechts Caption = "Anzahl der eingebauten Zähler" Enabled = 0 'False Height = 315 Left = 120 TabIndex = 98 Top = 270 Width = 2325 End End Begin VB.CommandButton cmdOK Caption = "Prüfung starten" DownPicture = "USPruefzaehlerPruefung.frx":000C BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 615 Left = 12330 TabIndex = 88 Top = 10350 Width = 1785 End Begin VB.CommandButton cmdCancel Cancel = -1 'True Caption = "Zurück" BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 615 Left = 9510 TabIndex = 87 Top = 10710 Width = 1785 End Begin VB.CommandButton cmdSPSInfo Caption = "Schaubild" BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 615 Left = 6870 TabIndex = 86 Top = 10680 Width = 1785 End Begin VB.Timer Timer1 Left = 10020 Top = 2100 End Begin VB.Frame Frame4 Caption = "Prüfgang Nr" Height = 735 Left = 11400 TabIndex = 35 Top = 8460 Width = 2715 Begin VB.Label lblPruefgangNr BorderStyle = 1 'Fest Einfach Height = 285 Left = 810 TabIndex = 36 Top = 300 Width = 1635 End End Begin VB.Frame Frame2 Caption = "Regelart" Height = 375 Left = 11400 TabIndex = 25 Top = 7980 Width = 2715 Begin VB.OptionButton OptRegelart Caption = "Servo" BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 375 Index = 1 Left = 240 TabIndex = 27 Top = 780 Visible = 0 'False Width = 2355 End Begin VB.OptionButton OptRegelart Caption = "Frequenzumrichter" BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 375 Index = 0 Left = 240 TabIndex = 26 Top = 360 Visible = 0 'False Width = 2355 End End Begin VB.Frame FrPruefer Caption = "Prüfer:" BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 735 Left = 11430 TabIndex = 23 Top = 900 Width = 2715 Begin VB.Label lblPruefer BackColor = &H00000000& BackStyle = 0 'Transparent Caption = "[Mitarbeiter Name]" BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 270 TabIndex = 24 Top = 300 Width = 2115 End End Begin VB.Frame FrpruefPunkte Caption = "Prüfpunkte" BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 6045 Left = 11400 TabIndex = 17 Top = 1770 Width = 2715 Begin VB.ComboBox cmbOrdnung Height = 315 Left = 1800 TabIndex = 44 Text = "Combo1" Top = 4800 Width = 615 End Begin VB.ListBox lstVorpruefpunkte BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 1020 Left = 240 TabIndex = 43 Top = 4800 Width = 1455 End Begin VB.ComboBox cmbPruefpunkte Height = 315 Left = 240 Style = 2 'Dropdown-Liste TabIndex = 34 Top = 4020 Width = 1635 End Begin VB.ListBox lstPruefpunkte BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 2220 Left = 240 TabIndex = 18 Top = 1350 Width = 2265 End Begin VB.Label Label4 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Ordnung" BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 400 Underline = -1 'True Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 240 Left = 1800 TabIndex = 46 Top = 4560 Width = 765 End Begin VB.Label Label2 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Vorprüfung:" BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 400 Underline = -1 'True Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 240 Left = 240 TabIndex = 45 Top = 4560 Width = 1020 End Begin VB.Label Label1 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Regulier-Prüfpunkt:" BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 400 Underline = -1 'True Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 240 Left = 240 TabIndex = 33 Top = 3690 Width = 1695 End Begin VB.Label lblMaxPP BackColor = &H00000000& BackStyle = 0 'Transparent Caption = "[Max. Prüfpunkte]" BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 240 TabIndex = 22 Top = 480 Width = 2115 End Begin VB.Label lblMaxPPInfo AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Max. Prüfpunkte:" BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 400 Underline = -1 'True Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 240 Left = 240 TabIndex = 21 Top = 240 Width = 1455 End Begin VB.Label lblUniquePP BackColor = &H00000000& BackStyle = 0 'Transparent Caption = "[Anz. Prüfpunkte]" BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 240 TabIndex = 20 Top = 1080 Width = 2115 End Begin VB.Label lblUniquePPInfo AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Eindeutige Prüfpunkte:" BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 400 Underline = -1 'True Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 240 Left = 240 TabIndex = 19 Top = 840 Width = 1995 End End Begin VB.Frame frEinbau BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 1095 Index = 1 Left = 480 TabIndex = 15 Top = 180 Width = 4185 Begin VB.CommandButton cmdRuecklaeuferanalyse Caption = "Rückläufer" Height = 225 Index = 1 Left = 2430 TabIndex = 137 Top = 780 Width = 945 End Begin VB.TextBox txtSerienNr BeginProperty Font Name = "MS Sans Serif" Size = 13.5 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 405 Index = 1 Left = 120 TabIndex = 100 Top = 540 Width = 1695 End Begin VB.CommandButton cmdSerNrAusw Caption = "Snr." Enabled = 0 'False Height = 195 Index = 1 Left = 1920 TabIndex = 63 Top = 810 Width = 405 End Begin VB.Label lblStatus Caption = "Status:" BeginProperty Font Name = "Arial" Size = 9 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 435 Index = 1 Left = 1920 TabIndex = 37 Top = 420 Width = 1455 End Begin VB.Label lblEinbau Caption = "ABCDEFGHIJKLMNOPQRSTUVWXYZ123456789" Height = 315 Index = 1 Left = 120 TabIndex = 16 Top = 180 Width = 3675 End Begin VB.Image imgInfo Appearance = 0 '2D Height = 480 Index = 1 Left = 3630 Top = 600 Width = 480 End End Begin VB.Frame frame3 Caption = "Optionen" Height = 7815 Left = 6840 TabIndex = 28 Top = 2820 Width = 4485 Begin VB.Frame frmPrfArt Caption = "Prüfungsdurchführung" Height = 3735 Left = 240 TabIndex = 53 Top = 3870 Width = 4155 Begin VB.CheckBox chkZeroFlowJustage Caption = "Zeroflow Offset_Geber Justage" Height = 255 Left = 210 TabIndex = 158 Top = 2190 Value = 1 'Aktiviert Width = 3075 End Begin VB.CheckBox chkVersuch Caption = "Versuch-Prüfung" Height = 285 Left = 180 TabIndex = 157 Top = 3390 Width = 1665 End Begin VB.CheckBox chkHeissKaltSpreizungBerechnen Caption = "Heiss-Kalt Spreizung berechnen" Height = 255 Left = 540 TabIndex = 73 Top = 1170 Width = 2895 End Begin VB.CheckBox chkZeroflow Caption = "Zeroflow ST_Geber Justage" Height = 255 Left = 540 TabIndex = 72 Top = 1860 Visible = 0 'False Width = 2595 End Begin VB.CheckBox chkFunktionsprüfung Caption = "Funktionsprüfung " Height = 285 Left = 180 TabIndex = 71 Top = 3090 Width = 2085 End Begin VB.CheckBox chkNachjustage Caption = "Nachjustage (Werte aus Zähler beibehalten)" Height = 255 Left = 180 TabIndex = 70 Top = 240 Width = 3435 End Begin VB.CheckBox chkBereichsjustage Caption = "Bereichs Justage" Height = 255 Left = 540 TabIndex = 69 Top = 1500 Width = 1755 End Begin VB.CheckBox chkKontinuierlich Caption = "Prüfung mit kontinuierlichem Durchfluß" Height = 255 Left = 180 TabIndex = 56 Top = 2520 Width = 3075 End Begin VB.CheckBox chkHauptpruefung Caption = "Prüfzähler-Hauptprüfung " Height = 285 Left = 180 TabIndex = 55 Top = 2820 Value = 1 'Aktiviert Width = 2085 End Begin VB.CheckBox chkVorpruefung Caption = "Vorprüfung Justage (Qmax und Qmin)" Height = 255 Left = 180 TabIndex = 54 Top = 840 Value = 1 'Aktiviert Width = 3135 End Begin VB.CheckBox chkVorjustage Caption = "Vorjustage (auf < ± 10% bei Qmin)" Height = 255 Left = 180 TabIndex = 135 Top = 540 Width = 2895 End End Begin VB.Frame Frame5 Caption = "Hauptprüfung mit" Height = 1305 Left = 240 TabIndex = 50 Top = 2550 Width = 2415 Begin VB.OptionButton OptPrfArt Caption = "Referenzzähler" BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 435 Index = 1 Left = 240 TabIndex = 52 Top = 720 Width = 1965 End Begin VB.OptionButton OptPrfArt Caption = "Waage" BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 435 Index = 0 Left = 240 TabIndex = 51 Top = 360 Width = 1905 End End Begin VB.Frame Frame1 Caption = "Vorprüfung mit" Height = 1065 Left = 240 TabIndex = 47 Top = 1320 Width = 2415 Begin VB.OptionButton OptVorPrfArt Caption = "Waage" BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Index = 0 Left = 240 TabIndex = 49 Top = 360 Width = 1575 End Begin VB.OptionButton OptVorPrfArt Caption = "Referenzzähler" BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 435 Index = 1 Left = 240 TabIndex = 48 Top = 600 Width = 1935 End End Begin VB.TextBox txtAnzahlDauerPrf Enabled = 0 'False Height = 315 Left = 1890 TabIndex = 31 Text = "1" Top = 630 Width = 495 End Begin VB.CheckBox chkDauerpruefung Caption = "Dauerprüfung" BeginProperty Font Name = "Arial" Size = 9.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 375 Left = 420 TabIndex = 30 Top = 240 Width = 1995 End Begin VB.CheckBox chkPruefgangLang Caption = "Prüfgang Lang" BeginProperty Font Name = "Arial" Size = 9.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 375 Left = 420 TabIndex = 29 Top = 930 Width = 1995 End Begin VB.Shape shpLock FillColor = &H000000FF& FillStyle = 0 'Ausgefüllt Height = 405 Index = 1 Left = 3450 Shape = 4 'Gerundetes Rechteck Top = 2520 Visible = 0 'False Width = 405 End Begin VB.Label lblLock Appearance = 0 '2D BackColor = &H008080FF& BorderStyle = 1 'Fest Einfach Caption = "Zähler messen mit eigenem Fühler" BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H80000008& Height = 825 Left = 2790 TabIndex = 122 ToolTipText = "Sicherstellen, dass der Vor- oder Rücklauffühler, je nach Einbau Hinweis, die aktuelle Wassertemperatur mißt." Top = 3030 Visible = 0 'False Width = 1575 End Begin VB.Shape shpLock FillColor = &H000000FF& FillStyle = 0 'Ausgefüllt Height = 1935 Index = 0 Left = 3450 Shape = 4 'Gerundetes Rechteck Top = 480 Visible = 0 'False Width = 405 End Begin VB.Label lblDauer2 Caption = "Anzahl:" BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 315 Left = 1020 TabIndex = 32 Top = 660 Width = 915 End End Begin VB.Frame frEinbau BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 1095 Index = 2 Left = 480 TabIndex = 13 Top = 1200 Width = 4000 Begin VB.CommandButton cmdRuecklaeuferanalyse Caption = "Rückläufer" Height = 225 Index = 2 Left = 2460 TabIndex = 139 Top = 750 Width = 945 End Begin VB.TextBox txtSerienNr BeginProperty Font Name = "MS Sans Serif" Size = 13.5 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 405 Index = 2 Left = 120 TabIndex = 99 Top = 600 Width = 1695 End Begin VB.CommandButton cmdSerNrAusw Caption = "Snr." Enabled = 0 'False Height = 195 Index = 2 Left = 1950 TabIndex = 64 Top = 750 Width = 405 End Begin VB.Label lblStatus Caption = "Status" BeginProperty Font Name = "Arial" Size = 9 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 435 Index = 2 Left = 1890 TabIndex = 38 Top = 480 Width = 1455 End Begin VB.Image imgInfo Appearance = 0 '2D Height = 480 Index = 2 Left = 3480 Top = 600 Width = 480 End Begin VB.Label lblEinbau Caption = "ABCDEFGHIJKLMNOPQRSTUVWXYZ123456789" Height = 375 Index = 2 Left = 60 TabIndex = 14 Top = 180 Width = 3675 End End Begin VB.Frame frEinbau BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 1095 Index = 3 Left = 480 TabIndex = 11 Top = 2220 Width = 4005 Begin VB.CommandButton cmdRuecklaeuferanalyse Caption = "Rückläufer" Height = 225 Index = 3 Left = 2400 TabIndex = 149 Top = 780 Width = 945 End Begin VB.CommandButton cmdSerNrAusw Caption = "Snr." Enabled = 0 'False Height = 195 Index = 3 Left = 1920 TabIndex = 65 Top = 780 Width = 405 End Begin VB.TextBox txtSerienNr BeginProperty Font Name = "MS Sans Serif" Size = 13.5 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 405 Index = 3 Left = 120 TabIndex = 0 Top = 600 Width = 1695 End Begin VB.Label lblStatus Caption = "Status:" BeginProperty Font Name = "Arial" Size = 9 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 435 Index = 3 Left = 1920 TabIndex = 39 Top = 540 Width = 1515 End Begin VB.Image imgInfo Appearance = 0 '2D Height = 480 Index = 3 Left = 3480 Top = 600 Width = 480 End Begin VB.Label lblEinbau Caption = "ABCDEFGHIJKLMNOPQRSTUVWXYZ123456789" Height = 375 Index = 3 Left = 120 TabIndex = 12 Top = 180 Width = 3675 End End Begin VB.Frame frEinbau BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 1095 Index = 4 Left = 480 TabIndex = 9 Top = 3240 Width = 4005 Begin VB.CommandButton cmdRuecklaeuferanalyse Caption = "Rückläufer" Height = 225 Index = 4 Left = 2430 TabIndex = 150 Top = 750 Width = 945 End Begin VB.CommandButton cmdSerNrAusw Caption = "Snr." Enabled = 0 'False Height = 195 Index = 4 Left = 1920 TabIndex = 66 Top = 750 Width = 405 End Begin VB.TextBox txtSerienNr BeginProperty Font Name = "MS Sans Serif" Size = 13.5 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 405 Index = 4 Left = 120 TabIndex = 1 Top = 600 Width = 1695 End Begin VB.Label lblStatus Caption = "Status:" BeginProperty Font Name = "Arial" Size = 9 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 435 Index = 4 Left = 1860 TabIndex = 40 Top = 480 Width = 1455 End Begin VB.Image imgInfo Appearance = 0 '2D Height = 480 Index = 4 Left = 3480 Top = 600 Width = 480 End Begin VB.Label lblEinbau Caption = "ABCDEFGHIJKLMNOPQRSTUVWXYZ123456789" Height = 255 Index = 4 Left = 180 TabIndex = 10 Top = 240 Width = 3735 End End Begin VB.Frame frEinbau BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 1095 Index = 5 Left = 480 TabIndex = 7 Top = 4260 Width = 4000 Begin VB.CommandButton cmdRuecklaeuferanalyse Caption = "Rückläufer" Height = 225 Index = 5 Left = 2400 TabIndex = 151 Top = 780 Width = 945 End Begin VB.CommandButton cmdSerNrAusw Caption = "Snr." Enabled = 0 'False Height = 195 Index = 5 Left = 1920 TabIndex = 67 Top = 810 Width = 405 End Begin VB.TextBox txtSerienNr BeginProperty Font Name = "MS Sans Serif" Size = 13.5 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 405 Index = 5 Left = 60 TabIndex = 2 Top = 600 Width = 1695 End Begin VB.Label lblStatus Caption = "Status:" BeginProperty Font Name = "Arial" Size = 9 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 435 Index = 5 Left = 1860 TabIndex = 41 Top = 540 Width = 1455 End Begin VB.Image imgInfo Appearance = 0 '2D Height = 480 Index = 5 Left = 3480 Top = 600 Width = 480 End Begin VB.Label lblEinbau Caption = "ABCDEFGHIJKLMNOPQRSTUVWXYZ123456789" Height = 375 Index = 5 Left = 240 TabIndex = 8 Top = 360 Width = 3675 End End Begin VB.Frame frEinbau BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 1095 Index = 6 Left = 480 TabIndex = 5 Top = 5280 Width = 4000 Begin VB.CommandButton cmdRuecklaeuferanalyse Caption = "Rückläufer" Height = 225 Index = 6 Left = 2370 TabIndex = 152 Top = 780 Width = 945 End Begin VB.CommandButton cmdSerNrAusw Caption = "Snr." Enabled = 0 'False Height = 195 Index = 6 Left = 1860 TabIndex = 68 Top = 810 Width = 405 End Begin VB.TextBox txtSerienNr BeginProperty Font Name = "MS Sans Serif" Size = 13.5 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 405 Index = 6 Left = 60 TabIndex = 3 Top = 600 Width = 1695 End Begin VB.Label lblStatus Caption = "Status:" BeginProperty Font Name = "Arial" Size = 9 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 285 Index = 6 Left = 1860 TabIndex = 42 Top = 540 Width = 1455 End Begin VB.Image imgInfo Appearance = 0 '2D Height = 480 Index = 6 Left = 3480 Top = 540 Width = 480 End Begin VB.Label lblEinbau Caption = "ABCDEFGHIJKLMNOPQRSTUVWXYZ123456789" Height = 375 Index = 6 Left = 240 TabIndex = 6 Top = 240 Width = 3675 End End Begin VB.Frame frEinbau BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 1095 Index = 7 Left = 480 TabIndex = 74 Top = 6300 Width = 4000 Begin VB.CommandButton cmdRuecklaeuferanalyse Caption = "Rückläufer" Height = 225 Index = 7 Left = 2400 TabIndex = 153 Top = 780 Width = 945 End Begin VB.TextBox txtSerienNr BeginProperty Font Name = "MS Sans Serif" Size = 13.5 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 405 Index = 7 Left = 60 TabIndex = 76 Top = 600 Width = 1695 End Begin VB.CommandButton cmdSerNrAusw Caption = "Snr." Enabled = 0 'False Height = 195 Index = 7 Left = 1920 TabIndex = 75 Top = 810 Width = 405 End Begin VB.Image imgInfo Appearance = 0 '2D Height = 480 Index = 7 Left = 3480 Top = 600 Width = 480 End Begin VB.Label lblStatus Caption = "Status:" BeginProperty Font Name = "Arial" Size = 9 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 285 Index = 7 Left = 1890 TabIndex = 77 Top = 510 Width = 1455 End Begin VB.Label lblEinbau Caption = "ABCDEFGHIJKLMNOPQRSTUVWXYZ123456789" Height = 375 Index = 7 Left = 120 TabIndex = 78 Top = 240 Width = 3675 End End Begin VB.Frame frEinbau BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 1095 Index = 8 Left = 480 TabIndex = 79 Top = 7380 Width = 4000 Begin VB.CommandButton cmdRuecklaeuferanalyse Caption = "Rückläufer" Height = 225 Index = 8 Left = 2430 TabIndex = 154 Top = 810 Width = 945 End Begin VB.CommandButton cmdSerNrAusw Caption = "Snr." Enabled = 0 'False Height = 195 Index = 8 Left = 1980 TabIndex = 81 Top = 810 Width = 405 End Begin VB.TextBox txtSerienNr BeginProperty Font Name = "MS Sans Serif" Size = 13.5 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 405 Index = 8 Left = 180 TabIndex = 80 Top = 540 Width = 1695 End Begin VB.Label lblStatus Caption = "Status:" BeginProperty Font Name = "Arial" Size = 9 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Index = 8 Left = 1950 TabIndex = 83 Top = 570 Width = 1455 End Begin VB.Image imgInfo Appearance = 0 '2D Height = 480 Index = 8 Left = 3480 Top = 540 Width = 480 End Begin VB.Label lblEinbau Caption = "ABCDEFGHIJKLMNOPQRSTUVWXYZ123456789" Height = 375 Index = 8 Left = 180 TabIndex = 82 Top = 270 Width = 3675 End End Begin VB.Frame frEinbau BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 1095 Index = 9 Left = 480 TabIndex = 89 Top = 8400 Width = 4000 Begin VB.CommandButton cmdRuecklaeuferanalyse Caption = "Rückläufer" Height = 225 Index = 9 Left = 2490 TabIndex = 155 Top = 780 Width = 945 End Begin VB.TextBox txtSerienNr BeginProperty Font Name = "MS Sans Serif" Size = 13.5 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 405 Index = 9 Left = 240 TabIndex = 91 Top = 540 Width = 1695 End Begin VB.CommandButton cmdSerNrAusw Caption = "Snr." Enabled = 0 'False Height = 195 Index = 9 Left = 2040 TabIndex = 90 Top = 810 Width = 405 End Begin VB.Label lblEinbau Caption = "ABCDEFGHIJKLMNOPQRSTUVWXYZ123456789" Height = 375 Index = 9 Left = 180 TabIndex = 93 Top = 180 Width = 3675 End Begin VB.Image imgInfo Appearance = 0 '2D Height = 480 Index = 9 Left = 3480 Top = 540 Width = 480 End Begin VB.Label lblStatus Caption = "Status:" BeginProperty Font Name = "Arial" Size = 9 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 435 Index = 9 Left = 2010 TabIndex = 92 Top = 540 Width = 1455 End End Begin VB.Frame frEinbau BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 1095 Index = 10 Left = 480 TabIndex = 103 Top = 9420 Width = 4000 Begin VB.CommandButton cmdRuecklaeuferanalyse Caption = "Rückläufer" Height = 225 Index = 10 Left = 2490 TabIndex = 156 Top = 780 Width = 945 End Begin VB.CommandButton cmdSerNrAusw Caption = "Snr." Enabled = 0 'False Height = 195 Index = 10 Left = 2040 TabIndex = 105 Top = 810 Width = 405 End Begin VB.TextBox txtSerienNr BeginProperty Font Name = "MS Sans Serif" Size = 13.5 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 405 Index = 10 Left = 240 TabIndex = 104 Top = 540 Width = 1695 End Begin VB.Label lblStatus Caption = "Status:" BeginProperty Font Name = "Arial" Size = 9 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 435 Index = 10 Left = 2010 TabIndex = 107 Top = 540 Width = 1455 End Begin VB.Image imgInfo Appearance = 0 '2D Height = 480 Index = 10 Left = 3480 Top = 540 Width = 480 End Begin VB.Label lblEinbau Caption = "ABCDEFGHIJKLMNOPQRSTUVWXYZ123456789" Height = 375 Index = 10 Left = 180 TabIndex = 106 Top = 180 Width = 3675 End End Begin VB.Label lblFehler50 BorderStyle = 1 'Fest Einfach Caption = "50°Qmin" Height = 255 Index = 10 Left = 5820 TabIndex = 132 Top = 9960 Visible = 0 'False Width = 735 End Begin VB.Label lblFehler50 BorderStyle = 1 'Fest Einfach Caption = "50°Qmin" Height = 255 Index = 9 Left = 5820 TabIndex = 131 Top = 8970 Visible = 0 'False Width = 735 End Begin VB.Label lblFehler50 BorderStyle = 1 'Fest Einfach Caption = "50°Qmin" Height = 255 Index = 8 Left = 5820 TabIndex = 130 Top = 7890 Visible = 0 'False Width = 735 End Begin VB.Label lblFehler50 BorderStyle = 1 'Fest Einfach Caption = "50°Qmin" Height = 255 Index = 7 Left = 5820 TabIndex = 129 Top = 6900 Visible = 0 'False Width = 735 End Begin VB.Label lblFehler50 BorderStyle = 1 'Fest Einfach Caption = "50°Qmin" Height = 255 Index = 6 Left = 5820 TabIndex = 128 Top = 5820 Visible = 0 'False Width = 735 End Begin VB.Label lblFehler50 BorderStyle = 1 'Fest Einfach Caption = "50°Qmin" Height = 255 Index = 5 Left = 5820 TabIndex = 127 Top = 4830 Visible = 0 'False Width = 735 End Begin VB.Label lblFehler50 BorderStyle = 1 'Fest Einfach Caption = "50°Qmin" Height = 255 Index = 4 Left = 5820 TabIndex = 126 Top = 3810 Visible = 0 'False Width = 735 End Begin VB.Label lblFehler50 BorderStyle = 1 'Fest Einfach Caption = "50°Qmin" Height = 255 Index = 3 Left = 5820 TabIndex = 125 Top = 2790 Visible = 0 'False Width = 735 End Begin VB.Label lblFehler50 BorderStyle = 1 'Fest Einfach Caption = "50°Qmin" Height = 255 Index = 2 Left = 5820 TabIndex = 124 Top = 1830 Visible = 0 'False Width = 735 End Begin VB.Label lblFehler50 BorderStyle = 1 'Fest Einfach Caption = "50°Qmin" Height = 255 Index = 1 Left = 5820 TabIndex = 123 Top = 780 Visible = 0 'False Width = 735 End Begin VB.Label lblNrEbp Caption = "10" BeginProperty Font Name = "MS Sans Serif" Size = 18 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 435 Index = 10 Left = 60 TabIndex = 118 Top = 9930 Width = 435 End Begin VB.Label lblNrEbp Caption = "9" BeginProperty Font Name = "MS Sans Serif" Size = 18 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 435 Index = 9 Left = 180 TabIndex = 117 Top = 8940 Width = 315 End Begin VB.Label lblNrEbp Caption = "8" BeginProperty Font Name = "MS Sans Serif" Size = 18 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 435 Index = 8 Left = 180 TabIndex = 116 Top = 7860 Width = 315 End Begin VB.Label lblNrEbp Caption = "7" BeginProperty Font Name = "MS Sans Serif" Size = 18 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 435 Index = 7 Left = 180 TabIndex = 115 Top = 6900 Width = 315 End Begin VB.Label lblNrEbp Caption = "6" BeginProperty Font Name = "MS Sans Serif" Size = 18 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 435 Index = 6 Left = 180 TabIndex = 114 Top = 5880 Width = 315 End Begin VB.Label lblNrEbp Caption = "5" BeginProperty Font Name = "MS Sans Serif" Size = 18 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 435 Index = 5 Left = 180 TabIndex = 113 Top = 4860 Width = 315 End Begin VB.Label lblNrEbp Caption = "4" BeginProperty Font Name = "MS Sans Serif" Size = 18 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 435 Index = 4 Left = 180 TabIndex = 112 Top = 3840 Width = 315 End Begin VB.Label lblNrEbp Caption = "3" BeginProperty Font Name = "MS Sans Serif" Size = 18 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 435 Index = 3 Left = 180 TabIndex = 111 Top = 2820 Width = 315 End Begin VB.Label lblNrEbp Caption = "2" BeginProperty Font Name = "MS Sans Serif" Size = 18 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 435 Index = 2 Left = 180 TabIndex = 110 Top = 1800 Width = 315 End Begin VB.Label lblNrEbp Caption = "1" BeginProperty Font Name = "MS Sans Serif" Size = 18 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 435 Index = 1 Left = 180 TabIndex = 109 Top = 780 Width = 315 End Begin VB.Label lblTimeout Caption = "0" Height = 195 Index = 10 Left = 5400 TabIndex = 108 Top = 9780 Width = 795 End Begin VB.Image imgSchloss Height = 405 Index = 10 Left = 5400 Top = 10080 Width = 375 End Begin VB.Image imgZaehler Height = 750 Index = 10 Left = 4740 MousePointer = 99 'Benutzerdefiniert Top = 9780 Width = 615 End Begin VB.Label lblTitle Alignment = 2 'Zentriert Caption = "Prüfvorbereitung der Ultraschall-Zähler Prüfung" BeginProperty Font Name = "MS Sans Serif" Size = 13.5 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 345 Left = 6270 TabIndex = 95 Top = 330 Width = 6915 End Begin VB.Image imgZaehler Height = 750 Index = 9 Left = 4740 MousePointer = 99 'Benutzerdefiniert Top = 8670 Width = 615 End Begin VB.Image imgSchloss Height = 405 Index = 9 Left = 5400 Top = 8970 Width = 375 End Begin VB.Label lblTimeout Caption = "0" Height = 195 Index = 8 Left = 5400 TabIndex = 94 Top = 7740 Width = 795 End Begin VB.Label lblTimeout Caption = "0" Height = 195 Index = 9 Left = 5400 TabIndex = 85 Top = 8700 Width = 795 End Begin VB.Label lblTimeout Caption = "0" Height = 195 Index = 7 Left = 5430 TabIndex = 84 Top = 6720 Width = 795 End Begin VB.Image imgSchloss Height = 405 Index = 8 Left = 5400 Top = 7980 Width = 375 End Begin VB.Image imgZaehler Height = 750 Index = 8 Left = 4740 MousePointer = 99 'Benutzerdefiniert Top = 7680 Width = 615 End Begin VB.Image imgSchloss Height = 405 Index = 7 Left = 5400 Top = 6990 Width = 375 End Begin VB.Image imgZaehler Height = 750 Index = 7 Left = 4740 MousePointer = 99 'Benutzerdefiniert Top = 6660 Width = 615 End Begin VB.Label lblTimeout Caption = "0" Height = 195 Index = 6 Left = 5400 TabIndex = 62 Top = 5640 Width = 765 End Begin VB.Label lblTimeout Caption = "0" Height = 315 Index = 5 Left = 5460 TabIndex = 61 Top = 4560 Width = 735 End Begin VB.Label lblTimeout Caption = "0" Height = 195 Index = 4 Left = 5460 TabIndex = 60 Top = 3660 Width = 705 End Begin VB.Label lblTimeout Caption = "0" Height = 195 Index = 3 Left = 5460 TabIndex = 59 Top = 2640 Width = 735 End Begin VB.Label lblTimeout Caption = "0" Height = 195 Index = 2 Left = 5460 TabIndex = 58 Top = 1620 Width = 795 End Begin VB.Label lblTimeout Caption = "123456" Height = 195 Index = 1 Left = 5400 TabIndex = 57 Top = 570 Width = 675 End Begin VB.Image imgSchloss Height = 375 Index = 6 Left = 5400 Top = 5940 Width = 375 End Begin VB.Image imgSchloss Height = 375 Index = 5 Left = 5400 Top = 4890 Width = 375 End Begin VB.Image imgSchloss Height = 375 Index = 4 Left = 5400 Top = 3930 Width = 375 End Begin VB.Image imgSchloss Height = 375 Index = 3 Left = 5400 Top = 2910 Width = 375 End Begin VB.Image imgSchloss Height = 375 Index = 2 Left = 5400 Top = 1830 Width = 375 End Begin VB.Image imgSchloss Height = 375 Index = 1 Left = 5400 Top = 870 Width = 375 End Begin VB.Image imgZaehler Height = 750 Index = 1 Left = 4740 MousePointer = 99 'Benutzerdefiniert Top = 480 Width = 615 End Begin VB.Image imgZaehler Height = 750 Index = 2 Left = 4740 MousePointer = 99 'Benutzerdefiniert Top = 1500 Width = 615 End Begin VB.Image imgZaehler Height = 750 Index = 3 Left = 4740 MousePointer = 99 'Benutzerdefiniert Top = 2550 Width = 615 End Begin VB.Image imgZaehler Height = 750 Index = 4 Left = 4740 MousePointer = 99 'Benutzerdefiniert Top = 3600 Width = 615 End Begin VB.Image imgZaehler Height = 750 Index = 5 Left = 4740 MousePointer = 99 'Benutzerdefiniert Top = 4560 Width = 615 End Begin VB.Image imgZaehler Height = 750 Index = 6 Left = 4740 MousePointer = 99 'Benutzerdefiniert Top = 5580 Width = 615 End Begin VB.Shape Shape2 BackColor = &H00FFC0C0& BackStyle = 1 'Undurchsichtig Height = 10815 Left = 4920 Top = 360 Width = 255 End End Begin VB.Timer timerBlink Enabled = 0 'False Left = 12240 Top = 240 End End Attribute VB_Name = "USPruefzaehlerPruefung" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False '============================================================================== ' ' File : PruefzaehlerPruefung.frm ' Date : 24.03.1999 ' Version: 1.00 ' Author : Reinhard Henning, Andreas Schmidt, lindner&partner ' '============================================================================== ' ' Einholen der Serien-Nr. für eine Prüfzählerprüfung ' '============================================================================== ' ' History: ' ' Date : 24.03.1999 ' Version: 1.00 ' Author : Reinhard Henning, Andreas Schmidt, lindner&partner ' ' Erste dokumentierte Version. ' '============================================================================== Option Explicit ' Private Variablen ' ----------------- Private m_nRet As Integer Private m_bInputChanged As Boolean Private m_bBlink As Boolean Private m_sOldInput As String Private m_colEinbauplatz As Collection Private m_colUniquePP As CPruefpunktCol Private m_colUniqueVorPP As CVorpruefpunktCol Private m_nEinbauplatz As Integer Private m_nSeriennummer As Long Private m_Regelart As String Private m_PruefungsArtWaage As Boolean Private m_VorPruefungsArtWaage As Boolean Private m_bDauerpruefung As Boolean Private m_bPruefgangLang As Boolean Private m_TimerOn As Boolean Private m_Pruefgang As CPruefgang Public m_SPS As CSPS Private mblnAbbruch As Boolean Private mlngRet As Long Const const_keineSNText As String = "keine SNr" Dim bTextChanged(10) As Boolean Dim bBlinkend(10) As Boolean Private Sub chkAuto_Click() If chkAuto.value = vbChecked Then txtAnzahl.Enabled = False Call updateAnzahl Else txtAnzahl.Enabled = True End If End Sub Private Sub chkDauerpruefung_click() If chkDauerpruefung.value = 1 Then m_bDauerpruefung = True lblDauer2.Enabled = True txtAnzahlDauerPrf.Enabled = True txtAnzahlDauerPrf.SelStart = 1 txtAnzahlDauerPrf.SelLength = 3 Else m_bDauerpruefung = False lblDauer2.Enabled = False txtAnzahlDauerPrf.Enabled = False txtAnzahlDauerPrf.text = "1" End If End Sub Private Sub chkHauptpruefung_Click() If chkKontinuierlich.value = vbChecked Then chkKontinuierlich.value = 0 End If End Sub Private Sub chkKontinuierlich_Click() If chkHauptpruefung.value = vbChecked Then chkHauptpruefung.value = 0 End If End Sub Private Sub chkProtokolldruck_Click() If chkProtokolldruck.value = vbChecked Then g_blnPruefprotokoll = True Else g_blnPruefprotokoll = False End If End Sub 'Private Sub chkKeineRegulierung_Click() ' If chkKeineRegulierung.Value = vbChecked Then ' chkRegulierung.Enabled = False ' Else ' chkRegulierung.Enabled = True ' End If ' Call chkRegulierung_Click 'End Sub Private Sub chkPruefgangLang_click() If chkPruefgangLang.value = 1 Then m_bPruefgangLang = True Else m_bPruefgangLang = False End If End Sub Private Function PruefpunkteZeitenVorhanden() As Boolean Dim Pruefpunkt As CPruefpunkt Dim Zeit As Double For Each Pruefpunkt In m_colUniquePP.getCollection Zeit = Pruefpunkt.GetTime Debug.Print "Prüfpunkt " & Pruefpunkt.getQ & ", Zeit: " & Zeit If Zeit = 0 Then ' Für einen Pruefpunkt ist keine Zeit definiert: sofort False zurückgeben PruefpunkteZeitenVorhanden = False Exit Function End If Next ' Alle Prüfpunkte haben Zeiten PruefpunkteZeitenVorhanden = True End Function Private Sub OrdnungChanged() Set m_colUniqueVorPP = calcVorpruefpunkte(m_colEinbauplatz) updatePruefpunkte End Sub Private Sub chkVersuch_Click() If chkVersuch.value = vbChecked Then g_blnVersuch = True Else g_blnVersuch = False End If End Sub Private Sub chkVorjustage_Click() If chkVorjustage.value = vbChecked Then chkNachjustage.Enabled = True Else If chkVorpruefung.value = vbUnchecked Then chkNachjustage.Enabled = False End If End If End Sub Private Sub chkVorpruefung_Click() If chkVorpruefung.value = vbUnchecked Then chkBereichsjustage.Enabled = False chkNachjustage.Enabled = False chkZeroflow.Enabled = False chkHeissKaltSpreizungBerechnen.Enabled = False Else chkBereichsjustage.Enabled = True chkNachjustage.Enabled = True chkZeroflow.Enabled = True chkHeissKaltSpreizungBerechnen.Enabled = True End If cmbOrdnung_Click End Sub Private Sub cmbOrdnung_Click() Debug.Print "cmbOrdnung_Click" Call OrdnungChanged If cmbOrdnung = 1 Then chkBereichsjustage.Enabled = False chkBereichsjustage.value = vbUnchecked Else chkBereichsjustage.Enabled = True chkBereichsjustage.value = vbChecked End If End Sub Private Sub cmdJustagewerte_Click(Index As Integer) Dim formJustageWerte As frmJustagewerte Dim Pruefzaehler As CPruefzaehler Dim Einbauplatz As CEinbauplatz Dim blnTimerwasOn As Boolean blnTimerwasOn = Timer1.Enabled StopScan DoEvents Set Einbauplatz = m_colEinbauplatz(Index) Set Pruefzaehler = Einbauplatz.getPruefzaehler Set formJustageWerte = New frmJustagewerte formJustageWerte.m_EinbauplatzNr = Index Set formJustageWerte.m_Pruefzaehler = Pruefzaehler Set formJustageWerte.m_Vorpruefpunkte = Pruefzaehler.getVorpruefpunkte formJustageWerte.Show vbModal If blnTimerwasOn Then txtSerienNr(Index).SetFocus 'StartScan End If End Sub Private Sub cmdOk_Click() Dim EinbauplatzNr As Integer g_Abbruch = False If txtAnzahl.text = "" Then chkAuto.value = vbChecked Call chkAuto_Click End If If Not SindZaehlerAehnlich() Then MsgBox ("Die Zähler sind zu unterschiedlich um zusammen geprüft zu werden") Exit Sub End If If Not PruefpunkteZeitenVorhanden() Then MsgBox ("Prüfpunktzeiten fehlen!" & vbCrLf & "Für alle Prüfpunkte müssen Zeiten definiert sein!") Exit Sub End If Call Hauptpruefung End Sub Private Sub cmdRuecklaeuferanalyse_Click(Index As Integer) Dim objForm As frmRuecklaeuferanalyse Dim Pruefzaehler As CPruefzaehler Dim Einbauplatz As CEinbauplatz Set objForm = New frmRuecklaeuferanalyse Set Einbauplatz = m_colEinbauplatz.Item(Index) Set Pruefzaehler = Einbauplatz.getPruefzaehler() objForm.m_EinbauplatzNr = Einbauplatz.getNr Set objForm.m_Pruefzaehler = Einbauplatz.getPruefzaehler Set objForm.m_Pruefgang = m_Pruefgang objForm.Show vbModal, Me End Sub ' Activiere die ProTool-Anwendung Private Sub cmdSPSInfo_Click() Call g_App.getSPS().ActivateProTool End Sub ' @return Code, mit dem endDialog aufgerufen wurde ' Public Function getExitCode() As Integer getExitCode = m_nRet End Function Private Sub cmdStopScan_Click() If m_TimerOn = False Then StartScan Else StopScan End If End Sub Private Sub Form_Activate() Call chkVorpruefung_Click End Sub Private Sub Form_Load() Dim i As Integer Dim nLeft As Long Dim nTop As Long Me.Width = Screen.Width Me.Height = Screen.Height Call centerFormInScreen(Me) ' Datenanzeigebereich zentrieren ' ------------------------------ nLeft = (Me.ScaleWidth - Me.frMain.Width) \ 2 nTop = (Me.ScaleHeight - Me.frMain.Height) \ 2 Me.frMain.BorderStyle = 0 Me.frMain.Left = nLeft Me.frMain.Top = nTop Set m_SPS = g_App.getSPS() For i = 1 To 10 cmdRuecklaeuferanalyse(i).Enabled = False If i > 1 Then txtSerienNr(i).Left = txtSerienNr(1).Left txtSerienNr(i).Top = txtSerienNr(1).Top txtSerienNr(i).Width = txtSerienNr(1).Width txtSerienNr(i).Height = txtSerienNr(1).Height cmdSerNrAusw(i).Left = cmdSerNrAusw(1).Left cmdSerNrAusw(i).Top = cmdSerNrAusw(1).Top cmdSerNrAusw(i).Width = cmdSerNrAusw(1).Width cmdSerNrAusw(i).Height = cmdSerNrAusw(1).Height lblStatus(i).Left = lblStatus(1).Left lblStatus(i).Top = lblStatus(1).Top lblStatus(i).Width = lblStatus(1).Width lblStatus(i).Height = lblStatus(1).Height cmdJustagewerte(i).Left = cmdJustagewerte(1).Left cmdJustagewerte(i).Top = cmdJustagewerte(1).Top cmdJustagewerte(i).Width = cmdJustagewerte(1).Width cmdJustagewerte(i).Height = cmdJustagewerte(1).Height lblEinbau(i).Left = lblEinbau(1).Left lblEinbau(i).Top = lblEinbau(1).Top lblEinbau(i).Width = lblEinbau(1).Width lblEinbau(i).Height = lblEinbau(1).Height imgInfo(i).Left = imgInfo(1).Left imgInfo(i).Top = imgInfo(1).Top imgInfo(i).Width = imgInfo(1).Width imgInfo(i).Height = imgInfo(1).Height End If imgZaehler(i).Picture = frmRes.imgZaehlerGrauLinks.Picture txtSerienNr(i).MaxLength = 10 imgZaehler(i).Enabled = False txtSerienNr(i).Enabled = False cmdJustagewerte(i).Visible = False If i <= g_App.Settings.EinbauplaetzeJeStrang Then Else lblNrEbp(i).Visible = False frEinbau(i).Visible = False imgZaehler(i).Visible = False lblTimeout(i).Visible = False cmdJustagewerte(i).Visible = False End If Next i lblPruefer = g_App.Mitarbeiter().getVorname() & " " & g_App.Mitarbeiter().getName() lblUniquePP = 0 lblMaxPP = g_App.Settings.getMaxPruefpunkte() lblTitle = "Prüfvorbereitung Ultraschallzähler" ' Initialisierung der RadioButtons "PruefungsArt" Select Case g_App.Settings.USPruefungsArt Case "Waage" OptPrfArt(0).value = True OptPrfArt(1).value = False m_PruefungsArtWaage = True Case "Referenzzaehler" OptPrfArt(0).value = False OptPrfArt(1).value = True m_PruefungsArtWaage = False Case Else ErrorMsg "keiner oder unbekannter Eintrag in ini-Datei für Prüfungsart" exitInstance End Select ' Initialisierung der CheckButtons "Funktionsprüfung" Select Case g_App.Settings.USFunktionspruefung Case "2" ' immer chkFunktionsprüfung.Enabled = False chkFunktionsprüfung.value = vbChecked Case "1" ' ja vorgeschlagen chkFunktionsprüfung.Enabled = True chkFunktionsprüfung.value = vbChecked Case "" ' nein vorgeschlagen chkFunktionsprüfung.Enabled = True chkFunktionsprüfung.value = vbUnchecked Case "0" ' verhindert chkFunktionsprüfung.value = vbUnchecked chkFunktionsprüfung.Enabled = False End Select If g_blnVersuch = True Then chkVersuch.value = vbChecked chkVersuch.Visible = True Else Select Case g_App.Settings.Versuch Case "0" chkVersuch.value = vbUnchecked chkVersuch.Visible = True g_blnVersuch = False Case "1" chkVersuch.Visible = True chkVersuch.value = vbChecked g_blnVersuch = True Case Else ' kein Ini Eintrag vorhanden chkVersuch.value = vbUnchecked chkVersuch.Visible = False g_blnVersuch = False End Select End If ' Initialisierung der RadioButtons "Vorprüfung PruefungsArt" Select Case g_App.Settings.USVorPruefungsArt Case "Waage" OptVorPrfArt(0).value = True OptVorPrfArt(1).value = False m_VorPruefungsArtWaage = True Case "Referenzzaehler" OptVorPrfArt(0).value = False OptVorPrfArt(1).value = True m_VorPruefungsArtWaage = False Case Else ErrorMsg "keiner oder unbekannter Eintrag in ini-Datei für USPrüfungsart" exitInstance End Select cmdOK.Enabled = False g_frmMain.Hide Call initEinbauplaetze ' Erzeuge Einbauplaetze Collection Call initRegelart ' Pruefgang Objekt erzeugen / Pruefgang starten Set m_Pruefgang = New CPruefgang ' Ultraschallzaehler initialisieren Call USinit cmbOrdnung.AddItem 1 cmbOrdnung.AddItem 2 'cmbOrdnung.AddItem 3 'cmbOrdnung.AddItem 4 'cmbOrdnung.AddItem 5 cmbOrdnung.ListIndex = 0 Me.Visible = True DoEvents mblnAbbruch = False 'MsgBox ("Zum Aktivieren der eingebauten Zähler mind. 2 Sekunden Taste drücken!") 'Neu AP 23.03.2004 'Wenn in der INI-Datei der Wert auf 0 steht oder nicht vorhanden ist, dann Anzeige dieser Warnungen If g_App.Settings.USTemperaturlock = 0 Then ' Zähler messen mit eigenem Füler lblLock.Visible = True shpLock(0).Visible = True shpLock(1).Visible = True ElseIf g_App.Settings.USTemperaturlock = 1 Then ' Zähler messen mit externem Fühler lblLock.Visible = False shpLock(0).Visible = False shpLock(1).Visible = False Else MsgBox "falscher Wert in INI: [USTemperaturlock] VerwendungExternerFuehler '" & g_App.Settings.USTemperaturlock & "'" End If chkVorjustage.Visible = True Select Case g_App.Settings.USVorjustage Case "0" chkVorjustage.Enabled = True chkVorjustage.value = vbUnchecked Case "1" chkVorjustage.Enabled = True chkVorjustage.value = vbChecked chkVorjustage.Visible = True Case "2" chkVorjustage.Enabled = False chkVorjustage.value = vbUnchecked Case "3" chkVorjustage.Enabled = False chkVorjustage.value = vbChecked chkVorjustage.Visible = True End Select Call chkVorpruefung_Click chkProtokolldruck_Click cmbOrdnung_Click If g_blnVersuch = True Then ' Auf Wunsch von C.Nettemann: chkVorjustage.value = vbUnchecked chkVorpruefung.value = vbUnchecked chkZeroFlowJustage.value = vbUnchecked End If StartScan End Sub ' Einbauplätze initialisieren ' Private Sub initEinbauplaetze() Dim i As Integer Dim Einbauplatz As CEinbauplatz Set m_colEinbauplatz = New Collection For i = 1 To g_App.Settings.EinbauplaetzeJeStrang Set Einbauplatz = New CEinbauplatz Call Einbauplatz.setNr(i) m_colEinbauplatz.Add Einbauplatz, Str$(i) Next i End Sub ' Regelart initialisieren Private Sub initRegelart() ' Todo: unter Q < 1 m^3 -> Servo verwenden -> für jeden PP individuell ' Vorbestzung aus INI Datei Select Case g_App.Settings.Regelart Case "FU" OptRegelart(0).value = True OptRegelart(1).value = False m_Regelart = "FU" Case "Servo" OptRegelart(0).value = False OptRegelart(1).value = True m_Regelart = "Servo" Case Else OptRegelart(0).value = False OptRegelart(1).value = False End Select End Sub '------------------------------------------------------------------------------ ' Private Funktionalität '------------------------------------------------------------------------------ ' Dialog beenden ' ' @param nRet Returncode des Dialogs ' Private Sub endDialog(nRet As Integer) m_nRet = nRet Unload Me g_frmMain.Show End Sub Private Sub Form_Unload(Cancel As Integer) g_frmMain.Show End Sub '------------------------------------------------------------------------------ ' Event-Handling '------------------------------------------------------------------------------ Private Sub cmdCancel_Click() cmdCancel.Enabled = False mblnAbbruch = True Timer1.Enabled = True End Sub Private Sub Formularbeenden() Dim Einbauplatz As CEinbauplatz Dim lngRet As Long Timer1.Enabled = False cmdCancel.Enabled = True Call StopScan Debug.Print "Verlassen der US Prüfung" Call endDialog(IDCANCEL) End Sub Private Sub imgSchloss_Click(Index As Integer) If imgSchloss(Index).Picture = frmRes.ImgSchlossOff.Picture Then ' If MsgBox("Möchten Sie das Schloß schließen ?", vbYesNo, "Das Schloß ist Offen") = vbYes Then ' Call USSchlossSchliessen(Index) ' txtSerienNr(Index).Text = "" ' imgSchloss(Index).Picture = frmRes.ImgLeer ' Call ueberpruefe(Index) ' End If Else If MsgBox("Möchten Sie das Schloß öffnen?", vbYesNo, "Das Schloß ist Geschlossen") = vbYes Then Call USSchlossOeffnen(Index) txtSerienNr(Index).text = "" imgSchloss(Index).Picture = frmRes.ImgLeer Call ueberpruefe(Index) End If End If End Sub ' Dialog zur Änderung der Prüfpunkte ' Private Sub imgZaehler_Click(Index As Integer) Dim Einbauplatz As CEinbauplatz Dim dlg As frmPruefvorgaben Set Einbauplatz = getEinbauplatz(Index) If Einbauplatz Is Nothing Then Exit Sub Me.MousePointer = vbHourglass Set dlg = New frmPruefvorgaben Call dlg.setPruefzaehler(Einbauplatz.getPruefzaehler()) Call dlg.setEinbauplatz(Einbauplatz) Set dlg.m_colEinbauplatz = m_colEinbauplatz If doModal(dlg, True) = IDOK Then Call updatePruefpunkte If g_MetrologAktualisieren = True Then AlleEinbauplaetzeDesGleichenAuftragesAktualisieren (Index) Else Call ueberpruefe(Index) End If End If Me.MousePointer = vbDefault End Sub Private Sub lblFehler50_Click(Index As Integer) ' load frmoptimizeFlow_fp ' frmoptimizeFlow_fp.EinbauplatzNr = Index ' frmoptimizeFlow_fp.Show vbModal, Me End Sub Private Sub OptVorPrfArt_Click(Index As Integer) Select Case Index Case 0 m_VorPruefungsArtWaage = True Case 1 m_VorPruefungsArtWaage = False End Select End Sub Private Sub OptPrfArt_Click(Index As Integer) Select Case Index Case 0 m_PruefungsArtWaage = True Case 1 m_PruefungsArtWaage = False End Select End Sub Private Sub OptRegelart_Click(Index As Integer) Select Case Index Case 0 m_Regelart = "FU" Case 1 m_Regelart = "Servo" End Select End Sub Private Sub txtAnzahl_Click() chkAuto.value = vbUnchecked txtAnzahl.SelStart = 0 txtAnzahl.SelLength = Len(txtAnzahl.text) End Sub ' Nur numerische Eingaben zulassen Private Sub txtAnzahlDauerPrf_KeyPress(KeyAscii As Integer) If Not IsNumeric(Chr$(KeyAscii)) Then If KeyAscii <> 8 Then KeyAscii = 0 Else If Len(txtAnzahlDauerPrf.text) > 2 Then KeyAscii = 0 End If End Sub Private Sub chkPruefgangLang_Validate(Cancel As Boolean) If Val(txtAnzahlDauerPrf.text) < 2 Or Val(txtAnzahlDauerPrf.text) > 9999 Then txtAnzahlDauerPrf.text = "1" End If End Sub Private Sub txtAnzahlDauerPrf_Validate(Cancel As Boolean) If Val(txtAnzahlDauerPrf.text) < 2 Or Val(txtAnzahlDauerPrf.text) > 9999 Then txtAnzahlDauerPrf.text = "1" chkDauerpruefung.value = 0 End If End Sub '---------------------------------------------------------------------------- ' Event Handling für das Scanner Eingabefeld '---------------------------------------------------------------------------- Private Sub txtScanner_KeyPress(KeyAscii As Integer) Dim nWert As Long If KeyAscii = 13 Then KeyAscii = 0 ' unterbinde Beep If IsNumeric(txtScanner) Then nWert = Val(txtScanner.text) If nWert > 0 And nWert <= g_App.Settings.EinbauplaetzeJeStrang Then m_nEinbauplatz = nWert txtScanner.text = "" lblScanner.caption = "Platz: " & Str(m_nEinbauplatz) End If If (nWert >= SERIENNR_MINWERT And nWert <= SERIENNR_MAXWERT) Then m_nSeriennummer = nWert txtScanner.text = "" lblScanner.caption = "SN:" & Str(m_nSeriennummer) End If If m_nEinbauplatz > 0 And m_nSeriennummer > 0 Then txtSerienNr(m_nEinbauplatz).text = FormatSerienNr(m_nSeriennummer) lblScanner.caption = Str(m_nEinbauplatz) & " : " & Str(m_nSeriennummer) Call ueberpruefe(m_nEinbauplatz) m_nEinbauplatz = 0 m_nSeriennummer = 0 End If Else txtScanner = "" beep End If End If End Sub '---------------------------------------------------------------------------- ' Event Handling für das SerienNr Eingabefeld '---------------------------------------------------------------------------- Private Sub txtSerienNr_Change(Index As Integer) bTextChanged(Index) = True End Sub Private Sub txtSerienNr_Click(Index As Integer) StopScan End Sub 'Eingefügt am 24.07.02 Pfeiffer Private Sub cmdSerNrAusw_Click(Index As Integer) StopScan txtSerienNr_DblClick (Index) End Sub Private Sub txtSerienNr_DblClick(Index As Integer) Dim frmDialog As frmSeriennrAuswahl Dim i As Integer Set frmDialog = New frmSeriennrAuswahl For i = 1 To 10 g_Seriennr(i) = txtSerienNr(i) Next frmDialog.Show vbModal, Me If IsNumeric(frmDialog.sSerienNr) Then txtSerienNr(Index).text = frmDialog.sSerienNr bTextChanged(Index) = True txtSerienNr(Index).SetFocus End If End Sub Private Sub txtSerienNr_GotFocus(Index As Integer) m_sOldInput = txtSerienNr(Index).text CursorAnEndeImSerienNrField (Index) ' selectSerienNrField (Index) End Sub Private Sub txtSerienNr_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer) If KeyCode = 40 Then ' Setzt Fokus ins darunterliegende Textfeld bei Cursor-Down On Error Resume Next txtSerienNr(IIf(Index < g_App.Settings.EinbauplaetzeJeStrang, Index + 1, 1)).SetFocus ueberpruefe (Index) End If If KeyCode = 38 Then ' Setzt Fokus ins darüberliegende Textfeld bei Cursor-Up On Error Resume Next txtSerienNr(IIf(Index > 1, Index - 1, g_App.Settings.EinbauplaetzeJeStrang)).SetFocus ueberpruefe (Index) End If End Sub Private Sub txtSerienNr_KeyPress(Index As Integer, KeyAscii As Integer) If KeyAscii = 13 Then If txtSerienNr(IIf(Index < g_App.Settings.EinbauplaetzeJeStrang, Index + 1, 1)).Enabled = True Then txtSerienNr(IIf(Index < g_App.Settings.EinbauplaetzeJeStrang, Index + 1, 1)).SetFocus End If ueberpruefe (Index) StartScan Else StopScan End If If Not IsNumeric(Chr$(KeyAscii)) Then If KeyAscii <> 8 Then KeyAscii = 0 End If End Sub ' Komplettes Feld selektieren ' Private Sub selectSerienNrField(Index As Integer) txtSerienNr(Index).SelStart = 0 txtSerienNr(Index).SelLength = Len(txtSerienNr(Index)) End Sub ' Komplettes Feld selektieren ' Private Sub CursorAnEndeImSerienNrField(Index As Integer) txtSerienNr(Index).SelStart = Len(txtSerienNr(Index)) txtSerienNr(Index).SelLength = 0 End Sub Private Sub txtSerienNr_LostFocus(Index As Integer) Debug.Print "LostFocus" If ActiveControl.Name <> "txtSerienNr" And txtSerienNr(Index) <> "" Then 'StopScan End If End Sub ' Validierung bei Fokus Wechsel in ein anderes Feld per Maus Private Sub txtSerienNr_Validate(Index As Integer, Cancel As Boolean) Debug.Print "Validate" Call ueberpruefe(Index) Cancel = False End Sub Private Sub ErstelleTestPruefzaehler(Index As Integer) Dim oAuftragPositionSerienNummer As CAuftragPositionSerienNr Dim lSerienNr As Long Dim Pruefzaehler As CPruefzaehler Dim Einbauplatz As CEinbauplatz Dim Pruefpunkte As CPruefpunkte lSerienNr = neueTestZaehlerSerienNr() If lSerienNr = 0 Then EntferneZaehlerAusEinbauplatz (Index) Exit Sub End If txtSerienNr(Index).text = FormatSerienNr(lSerienNr) Set oAuftragPositionSerienNummer = New CAuftragPositionSerienNr oAuftragPositionSerienNummer.setAuftragNr 99999 oAuftragPositionSerienNummer.setPositionNr 1 oAuftragPositionSerienNummer.setEinbauplatzNr Index oAuftragPositionSerienNummer.setNr lSerienNr oAuftragPositionSerienNummer.save Set Pruefzaehler = New CPruefzaehler Pruefzaehler.setSerienNr lSerienNr Set Einbauplatz = getEinbauplatz(Index) Einbauplatz.setPruefzaehler Pruefzaehler If Pruefzaehler.getPruefpunkte Is Nothing Then Set Pruefpunkte = PruefpunkteDesErstenPZmitPP(m_colEinbauplatz) Pruefzaehler.SetAuftragPositionSerienNr oAuftragPositionSerienNummer Pruefzaehler.setPruefpunkte Pruefpunkte If Pruefpunkte Is Nothing Then DebugMsg "Pruefpunkte sind für diesen Zähler nicht definiert" 'If MsgBox("Dieser Zaehler enthält keine Prüfpunktdaten in der Datenbank. Möchten Sie jetzt Prüfpunkte eingeben?", vbYesNo) = vbYes Then ' Call imgZaehler_Click(Index) 'Else ' txtSerienNr(Index).Text = "" ' Alternativ: 'txtSerienNr(Index).BackColor = vbRed ' Fokus setzen, um ein Validate Event zu bekommen: ' txtSerienNr(Index).SetFocus 'End If End If End If End Sub Private Function PruefpunkteDesErstenPZmitPP(ColEinbauplatz As Collection) As CPruefpunkte Dim Einbauplatz As CEinbauplatz Dim Pruefzaehler As CPruefzaehler Dim Pruefpunkte As CPruefpunkte For Each Einbauplatz In ColEinbauplatz If Not Einbauplatz.getPruefzaehler Is Nothing Then Set Pruefzaehler = Einbauplatz.getPruefzaehler If Not Pruefzaehler.getPruefpunkte Is Nothing Then If Pruefzaehler.getPruefpunkte.getPruefpunkte.Count > 0 Then Set PruefpunkteDesErstenPZmitPP = Pruefzaehler.getPruefpunkte Exit Function End If End If End If Next Set PruefpunkteDesErstenPZmitPP = Nothing End Function Private Sub ueberpruefe(Index As Integer) If bTextChanged(Index) = True Then bTextChanged(Index) = False ' Seriennummer wurde geändert If txtSerienNr(Index).text = "0" Then ErstelleTestPruefzaehler (Index) ueberpruefe (Index) Exit Sub End If If testSerienNrInput(Index) Then If txtSerienNr(Index) <> "" Then ' Wenn SerienNr Feld nicht gelöscht und SerienNrInput ' gerade erfolgreich getestet wurde, ' dann überprüfen, ob Pruefpunkte vorhanden sind. Wenn nicht, manuell PP eingeben. Call UeberpruefeAufPruefpunkte(Index) End If StartScan Else ' SerienNr wurde nicht akzeptiert txtSerienNr(Index).SetFocus End If Else ' nicht geändert End If If m_colUniquePP Is Nothing Then cmdOK.Enabled = False Else If m_colUniquePP.Count > 0 Then cmdOK.Enabled = True Else cmdOK.Enabled = False End If End If Call updateAnzahl End Sub Private Sub updateAnzahl() Dim iAnzahlPZ As Integer Dim Einbauplatz As CEinbauplatz For Each Einbauplatz In m_colEinbauplatz If Not Einbauplatz.getPruefzaehler Is Nothing Then iAnzahlPZ = iAnzahlPZ + 1 End If If chkAuto.value = vbChecked Then txtAnzahl.text = iAnzahlPZ End If Next End Sub Private Sub loescheFabNr(lngSerienNr As Long, lngFabNr As Long) Dim rs As CRecordset Set rs = New CRecordset rs.openRS "UPDATE AuftragPositionSerienNr set FabNr = NULL WHERE SerienNr=" & lngSerienNr & " and FabNr=" & lngFabNr End Sub '--------------------------------------------------------------- ' ermittelt neue Test-Prüfzähler Seriennummer ' Private Function neueTestZaehlerSerienNr() As Long Dim SQL As String Dim SerienNr As Long Dim rs As CRecordset Dim NummernbandID As Long Dim ueberlauf As Long Set rs = New CRecordset SQL = "select * from Nummernband where NummernbandID=" & g_App.Settings.NummernbandID & ";" If rs.openRS(SQL) Then If Not rs.EOF Then SerienNr = rs.getLongValue("letzteNr") ueberlauf = rs.getLongValue("bisSerienNr") - SerienNr ' Wenn wirklich Überlauf auftritt: Meldung ! If SerienNr >= rs.getLongValue("bisSerienNr") Then ErrorMsg ("Überlauf im Nummernband für Testzähler") Exit Function End If If ueberlauf < 1000 Then MsgBox ("Überlauf nach " & ueberlauf & " Seriennummern bei " & rs.getLongValue("bisSerienNr") & ". Bitte Admin verständigen.....") End If SerienNr = SerienNr + 1 rs.setValue "letzteNr", SerienNr rs.update neueTestZaehlerSerienNr = SerienNr Else ErrorMsg ("Das Testzähler Nummernband ist in der Datenbank nicht definiert") End If End If End Function '---------------------------------------------------------------------------- ' @param nNr Nr. eines Einbauplatzes ' ' @return Einbauplatz aus der Collection der Einbauplätze ' mit der angegebenen Nr. oder nothing, wenn es zu ' der Nr. keinen Einbauplatz gibt ' Private Function getEinbauplatz(nNr As Integer) As CEinbauplatz Dim Einbauplatz As CEinbauplatz For Each Einbauplatz In m_colEinbauplatz If Einbauplatz.getNr() = nNr Then Set getEinbauplatz = Einbauplatz Exit Function End If Next End Function ' Menge der eindeutigen Prüfpunkte neu bilden und ' Summe neu anzeigen ' ' TODO: Komplettieren ' Public Sub updatePruefpunkte() Dim Einbauplatz As CEinbauplatz Dim i As Integer Set m_colUniquePP = calcPruefpunkte(m_colEinbauplatz) Set m_colUniqueVorPP = calcVorpruefpunkte(m_colEinbauplatz) ' Anzeige der eindeutigen Prüfpunkte aktualisieren lblUniquePP = m_colUniquePP.Count ' Listboxen für Pruefpunkte aktualisieren lstPruefpunkte.Clear cmbPruefpunkte.Clear m_colUniquePP.sortQ For i = 1 To m_colUniquePP.Count() lstPruefpunkte.AddItem m_colUniquePP.Item(i).getQ & " (" & m_colUniquePP.Item(i).GetTime & " s = " & Format(m_colUniquePP.Item(i).getQ * m_colUniquePP.Item(i).GetTime / 3.6, "0") & " l)" cmbPruefpunkte.AddItem m_colUniquePP.Item(i).getQ Next i If m_colUniquePP.Count() > 0 Then cmbPruefpunkte.ListIndex = 0 End If lstVorpruefpunkte.Clear m_colUniqueVorPP.sortQ For i = 1 To m_colUniqueVorPP.Count lstVorpruefpunkte.AddItem m_colUniqueVorPP.Item(i).getQ Next i ' PP-Warning-Flag für alle Einbauplätze auf FALSE setzen For Each Einbauplatz In m_colEinbauplatz Call Einbauplatz.setPPWarning(False) Next ' Wenn die Menge der eindeutigen Prüfpunkte > dem Maximum in ' der INI-Datei ist, feststellen, welche Zähler das Problem sind. If m_colUniquePP.Count <= g_App.Settings.getMaxPruefpunkte() Then For Each Einbauplatz In m_colEinbauplatz Call Einbauplatz.setPPWarning(False) ' TodoTodo Call updateEinbauplatz(Einbauplatz.getNr()) Next Exit Sub End If ' Ausnahmezähler suchen und austragen, bis Maximum unterschritten ist ' ' Vorgehensweise: ' - Alle CPruefpunkt-Items in m_colUniquePP absteigend nach dem UseCount ' sortieren ' - Zaehler zu den Prüfpunkt(en) mit dem kleinsten UseCount feststellen ' und aus der Menge der Prüfzaehler ausklammern Dim uniquePPcopy As CPruefpunktCol ' menge der eindeutigen Pruefpunkte erzeugen und ' absteigend nach dem "UseCount" sortieren Set uniquePPcopy = New CPruefpunktCol For i = 1 To m_colUniquePP.Count() uniquePPcopy.Add m_colUniquePP.Item(i) Next i Call uniquePPcopy.sortUseCount ' welche(r) Zähler gehören zu dem an wenigsten benötigten Prüfpunkt? Dim dQ As Double dQ = uniquePPcopy.Item(1).getQ() For Each Einbauplatz In m_colEinbauplatz Dim Pruefpunkte As CPruefpunkte If Not Einbauplatz.getPruefzaehler() Is Nothing Then Set Pruefpunkte = Einbauplatz.getPruefzaehler().getPruefpunkte() If Not Pruefpunkte Is Nothing Then If Pruefpunkte.hasQ(dQ) Then Call Einbauplatz.setPPWarning(True) End If End If End If Call updateEinbauplatz(Einbauplatz.getNr()) Next End Sub ' Neu eingegebene Serien-Nr. überprüfen ' ' @return true = Prüfzähler mit der übergebenen Serien-Nr. wurde dem ' Einbauplatz erfolgreich zugewiesen ' Private Function testSerienNrInput(Index As Integer) As Boolean Dim Einbauplatz As CEinbauplatz Dim lSerienNr As Long Dim Pruefzaehler As CPruefzaehler Dim Pruefpunkte As CPruefpunkte Dim nTmpText As String Dim Impulswertigkeit As Long Set Einbauplatz = getEinbauplatz(Index) ' Eingabe ist Einbauplatz Nummer If Val(txtSerienNr(Index)) > 0 And Val(txtSerienNr(Index)) <= g_App.Settings.EinbauplaetzeJeStrang Then ' Cursor laut Eingabe ins angewählte Feld setzen If txtSerienNr(Val(txtSerienNr(Index))).Enabled = True Then nTmpText = txtSerienNr(Index).text txtSerienNr(Index).text = m_sOldInput txtSerienNr(Val(nTmpText)).SetFocus GoTo testSerienNrInputReturnOK Else GoTo testSerienNrInputReturnFalse End If End If If Trim$(txtSerienNr(Index)) = "" Then ' Seriennummer wurde gelöscht lSerienNr = -1 ' Prüfen, ob noch irgendeine Seriennummer definiert ist Dim bKeinPruefzaehler As Boolean bKeinPruefzaehler = True Dim i As Integer For i = 1 To g_App.Settings.EinbauplaetzeJeStrang If txtSerienNr(i) <> "" Then bKeinPruefzaehler = False End If Next Else lSerienNr = Val(txtSerienNr(Index)) End If ' Setze im Einbauplatz Objekt die Seriennr. (laut DB) If Not setEinbauplatzPruefzaehler(Einbauplatz, lSerienNr) Then ' Fehlgeschlagen: GoTo testSerienNrInputReturnFalse End If '---------- testSerienNrInputReturnOK: Call updateZaehlerImage(Index) testSerienNrInput = True If Not Pruefzaehler Is Nothing Then Set Pruefzaehler = Einbauplatz.getPruefzaehler Set Pruefpunkte = Pruefzaehler.getPruefpunkte ' Todo: Verbesserung: Abweisen eines Zählers, wenn Regulierdaten ' des Zählers nicht gleich den globalen Regulierdaten sind. If Pruefpunkte Is Nothing Then ErrorMsg ("Es sind keine Prüfpunkte ermittelt worden") End If End If Call updatePruefpunkte Call Show50GradFehlerBeiQmin(Index) GoTo testSerienNrInputReturn testSerienNrInputReturnFalse: Call selectSerienNrField(Index) Call updateZaehlerImage(Index) txtSerienNr(Index).SetFocus testSerienNrInput = False testSerienNrInputReturn: 'On Error Resume Next Call updateEinbauplatz(Index) Exit Function End Function ' Menge aller eindeutigen Prüfpunkte bilden ' ' @param Einbauplaetze Collection der Einbauplätze ' ' @return Collection mit allen eindeutigen CPruefpunkt-Objekten ' ' @see updatePruefpunkte ' ' geändert am 26.1.2000 von RH: arbeitet jetzt mit KopiePruefpunkt Private Function calcPruefpunkte(Einbauplaetze As Collection) As CPruefpunktCol Dim Einbauplatz As CEinbauplatz Dim Pruefpunkte As CPruefpunkte Dim Pruefpunkt As CPruefpunkt Dim colUniquePP As New CPruefpunktCol Dim nPos As Integer Dim i As Integer Dim KopiePruefpunkt As CPruefpunkt For Each Einbauplatz In Einbauplaetze If Not Einbauplatz.getPruefzaehler() Is Nothing Then Set Pruefpunkte = Einbauplatz.getPruefzaehler().getPruefpunkte() If Not Pruefpunkte Is Nothing Then If Not Pruefpunkte.getPruefpunkte Is Nothing Then For Each Pruefpunkt In Pruefpunkte.getPruefpunkte().getCollection() nPos = getEquivPruefpunktIndexFromCollection(Pruefpunkt, colUniquePP) If nPos = 0 Then ' Prüfpunkt ist noch nicht in der PPCollection vorhanden Call Pruefpunkt.setUseCount(1) Set KopiePruefpunkt = New CPruefpunkt KopiePruefpunkt.copyFrom Pruefpunkt colUniquePP.Add KopiePruefpunkt Else ' Prüfpunkt ist vorhanden ' Nur UseCount erhöhen Call colUniquePP.Item(nPos).incUseCount End If Next End If End If End If Next Set calcPruefpunkte = colUniquePP End Function ' Menge aller eindeutigen Vorprüfpunkte bilden ' ' @param Einbauplaetze Collection der Einbauplätze ' ' @return Collection mit allen eindeutigen CVorpruefpunkt-Objekten '' ' geändert am 26.1.2000 von RH: arbeitet jetzt mit KopiePruefpunkt ' geändert am 12.12.2001 von RH: Vorpruefpunkte übernommen aus Pruefpunkte Private Function calcVorpruefpunkte(Einbauplaetze As Collection) As CVorpruefpunktCol Dim Einbauplatz As CEinbauplatz Dim Vorpruefpunkt As CVorpruefpunkt Dim Vorpruefpunkte As CVorpruefpunkte Dim colUniqueVorPP As New CVorpruefpunktCol For Each Einbauplatz In Einbauplaetze If Not Einbauplatz.getPruefzaehler() Is Nothing Then Set Vorpruefpunkte = Einbauplatz.getPruefzaehler().getVorpruefpunkte() If Not Vorpruefpunkte Is Nothing Then If Not Vorpruefpunkte.getPruefpunkte Is Nothing Then For Each Vorpruefpunkt In Vorpruefpunkte.getPruefpunkte().getCollection() Debug.Print "---" Debug.Print "Q: " & Vorpruefpunkt.getQ Debug.Print "n: " & Vorpruefpunkt.getOrdnung Debug.Print "t: " & Vorpruefpunkt.GetTime If Vorpruefpunkt.getOrdnung <= Val(cmbOrdnung.text) Then Debug.Print "Ist dabei in Ordnung " & cmbOrdnung.text colUniqueVorPP.Add Vorpruefpunkt Else Debug.Print "Ist NICHT dabei in Ordnung " & cmbOrdnung.text End If Next Set calcVorpruefpunkte = colUniqueVorPP Exit Function End If End If End If Next Set calcVorpruefpunkte = colUniqueVorPP End Function ' Testet, ob der Durchfluss des uebergebenen Pruefpunkt-Objekts ' in der übergebenen Collection von Pruefpunkten enthalten ist. ' Private Function getEquivPruefpunktIndexFromCollection(TestPruefpunkt As CPruefpunkt, colPruefpunkte As CPruefpunktCol) As Integer Dim Pruefpunkt As CPruefpunkt Dim i As Integer For i = 1 To colPruefpunkte.Count Set Pruefpunkt = colPruefpunkte.Item(i) If Pruefpunkt.getQ() = TestPruefpunkt.getQ() Then getEquivPruefpunktIndexFromCollection = i Exit Function End If Next End Function ' Prüfzähler-Objekt in dem angegebenen Einbauplatz löschen ' Der Einbauplatz ist danach wieder als "nicht in Verwendung" deklariert. ' Private Sub clearEinbauplatzPruefzaehler(nEinbauplatz As Integer) Dim Einbauplatz As CEinbauplatz Set Einbauplatz = getEinbauplatz(nEinbauplatz) If Not Einbauplatz Is Nothing Then Call Einbauplatz.setPruefzaehler(Nothing) End If End Sub ' Einbauplatz auf Basis der übergebenen Serien-Nr. den ' zugehörigen Prüfzähler zuweisen. ' ' @param Einbauplatz Einbauplatz-Objekt ' @param lSerienNr Nr. des Zählers ( -1 = Leerung) ' ' @return true = Prüfzähler konnte dem Einbauplatz zugewiesen werden ' false = Serien-Nr. ist ungültig oder konnte nicht in der ' Datenbank gefunden werden ' Private Function setEinbauplatzPruefzaehler(Einbauplatz As CEinbauplatz, lSerienNr As Long) As Boolean Dim Pruefzaehler As CPruefzaehler Dim EinbauplatzNr As Integer setEinbauplatzPruefzaehler = False If Einbauplatz Is Nothing Then Call ErrorMsg("setEinbauplatzPruefzaehler: " + "Als Einbauplatz wurde nothing übergeben!") Exit Function End If If lSerienNr < 0 Then ' Prüfzähler wurde ausgebaut Call Einbauplatz.setPruefzaehler(Nothing) setEinbauplatzPruefzaehler = True ElseIf lSerienNr < SERIENNR_MINWERT Then ' Ungültige Serien-Nr. Call Einbauplatz.setPruefzaehler(Nothing) ElseIf lSerienNr > SERIENNR_MAXWERT Then ' Ungültige Serien-Nr. Call Einbauplatz.setPruefzaehler(Nothing) Else ' Seriennummer im gültigen Bereich Call Einbauplatz.setPruefzaehler(Nothing) Set Pruefzaehler = New CPruefzaehler DebugMsg "Prüfzähler " & lSerienNr & " am Einbauplatz " & Einbauplatz.getNr ' Prüfen, ob eine Auftragsposition existiert If Pruefzaehler.loadForSerienNr(lSerienNr) Then ' Prüfzähler vorhanden DebugMsg "Prüfzähler mit SerienNr " & lSerienNr & " am Einbauplatz " & Einbauplatz.getNr setEinbauplatzPruefzaehler = True Else ' Todo: muss ein Prüfzähler Objekt wirklich erzeugt werden ' wenn Seriennummer nicht in der Datenbank steht ? ' nur wenn TEST-Pruefzaehler: ' Call Pruefzaehler.setSerienNr(lSerienNr) End If Call Einbauplatz.setPruefzaehler(Pruefzaehler) End If End Function ' Taucht die Serien-Nr. des übergebenen Prüfzählers an verschiedenen ' Einbauplätzen auf? ' ' @param Pruefzaehler auf Eindeutigkeit zu überprüfender Prüfzähler ' ' Sonderfall: Prüfzähler mit der Serien-Nr. 0 dürfen mehrfach vorkommen ' Private Function hasDupes(Pruefzaehler As CPruefzaehler) As Boolean Dim Einbauplatz As CEinbauplatz If Not Pruefzaehler Is Nothing Then If Pruefzaehler.getSerienNr() <> 0 Then For Each Einbauplatz In m_colEinbauplatz If Not Einbauplatz.getPruefzaehler() Is Nothing Then If Not Einbauplatz.getPruefzaehler() Is Pruefzaehler Then If Einbauplatz.getPruefzaehler().getSerienNr() = Pruefzaehler.getSerienNr() Then hasDupes = True Exit Function End If End If End If Next End If End If End Function ' Zählerabbildung aktualisieren ' Private Sub updateZaehlerImage(nIndex As Integer) Dim Pruefzaehler As CPruefzaehler If Not getEinbauplatz(nIndex) Is Nothing Then Set Pruefzaehler = getEinbauplatz(nIndex).getPruefzaehler() ' Prüfzaehler an der Position eingebaut If Pruefzaehler Is Nothing Then imgZaehler(nIndex).Picture = frmRes.imgZaehlerGrauLinks.Picture imgZaehler(nIndex).Enabled = False ElseIf Pruefzaehler.isWarmwasserzaehler() Then imgZaehler(nIndex).Enabled = True imgZaehler(nIndex).Picture = frmRes.imgZaehlerRotLinks.Picture Else imgZaehler(nIndex).Enabled = True imgZaehler(nIndex).Picture = frmRes.imgZaehlerBlauLinks.Picture End If Else ' Kein Prüfzaehler an der Position eingebaut imgZaehler(nIndex).Picture = frmRes.imgZaehlerGrauLinks.Picture imgZaehler(nIndex).Enabled = False End If End Sub ' Einbauplatzdaten neu anzeigen ' ' '''todo:Diese Prozedur wird periodisch von dem Blink-Timer aufgerufen. ' ' @return true = Keine Fehlerbedingung festgestellt ' Private Function updateEinbauplatz(Index As Integer) As Boolean On Error Resume Next Dim blnOffsetJustagemoeglich As Boolean Dim Einbauplatz As CEinbauplatz Dim StatusFertigung As Integer Dim JustageWerte As CJustagewerte imgZaehler(Index).Enabled = True Set Einbauplatz = getEinbauplatz(Index) cmdRuecklaeuferanalyse(Index).Enabled = False If Einbauplatz.getPruefzaehler() Is Nothing Then ' Leere Eingabe, kein Prüfzähler eingebaut lblEinbau(Index).caption = "" txtSerienNr(Index).BackColor = &HFFFFFF imgZaehler(Index).Enabled = False ElseIf hasDupes(Einbauplatz.getPruefzaehler()) Then ' Doppelte Serien-Nr. lblEinbau(Index).caption = "Doppelte Serien-Nr." txtSerienNr(Index).BackColor = &HC0C0FF ' IIf(m_bBlink, &HC0C0FF, &HFFFFFF) imgZaehler(Index).Enabled = False ElseIf Einbauplatz.getPruefzaehler().getAuftragPosition() Is Nothing Then ' Ungültige Serien-Nr. lblEinbau(Index).caption = "keine Auftragsdaten!" txtSerienNr(Index).BackColor = &HC0C0FF ' IIf(m_bBlink, &HC0C0FF, &HFFFFFF) imgZaehler(Index).Enabled = False Else ' Alles OK? Dim Auftrag As CAuftrag Dim AuftragPosition As CAuftragPosition Dim Pruefzaehler As CPruefzaehler Dim sMsg As String Set Pruefzaehler = Einbauplatz.getPruefzaehler() Set Auftrag = Pruefzaehler.getAuftrag() Set AuftragPosition = Pruefzaehler.getAuftragPosition() cmdRuecklaeuferanalyse(Index).Enabled = True sMsg = "" If Auftrag Is Nothing Then sMsg = sMsg & "(unbekannt)" Else sMsg = sMsg & Auftrag.getNr() End If sMsg = sMsg & "/" If AuftragPosition Is Nothing Then sMsg = sMsg & "(unbekannt)" Else sMsg = sMsg & AuftragPosition.getNr() End If sMsg = sMsg & " " & Trim(Pruefzaehler.getIdentNrObj.getTyp & _ " " & Pruefzaehler.getIdentNrObj.getTypzusatz) sMsg = sMsg & " DN" & Pruefzaehler.getIdentNrObj.getNennweite sMsg = sMsg & " " & Pruefzaehler.getIdentNrObj.GetTemperatur & "G" sMsg = sMsg & "/PN" & Pruefzaehler.getIdentNrObj.getDruck sMsg = sMsg & "(" & Pruefzaehler.getPruefklasseKZ & ")" If Auftrag Is Nothing Or AuftragPosition Is Nothing Then lblEinbau(Index).caption = sMsg txtSerienNr(Index).BackColor = IIf(m_bBlink, &HC0C0FF, &HFFFFFF) imgZaehler(Index).Enabled = False Else lblEinbau(Index).caption = sMsg txtSerienNr(Index).BackColor = &HC0FFC0 imgZaehler(Index).Enabled = True End If StatusFertigung = Pruefzaehler.getAuftragPositionSerienNr.getStatusFertigung If StatusFertigung < 25 Then lblStatus(Index) = "neu" End If If StatusFertigung >= 25 And StatusFertigung < 30 Then lblStatus(Index).caption = "Wdh" End If If StatusFertigung >= 30 Then lblStatus(Index).caption = "keine Wdh erf." End If End If If Einbauplatz.getPPWarning() Then imgInfo(Index).Picture = frmRes.imgWarning.Picture imgInfo(Index).Visible = True Else imgInfo(Index).Visible = False End If Set JustageWerte = New CJustagewerte If Not Pruefzaehler Is Nothing Then JustageWerte.SerienNr = Pruefzaehler.getSerienNr blnOffsetJustagemoeglich = HauptprfOffsetjustage(Pruefzaehler.getSerienNr, Pruefzaehler.getVorpruefpunkte, False) If JustageWerte.load = True Then If blnOffsetJustagemoeglich = True Then cmdJustagewerte(Index).Visible = True cmdJustagewerte(Index).Enabled = True Else cmdJustagewerte(Index).Visible = False End If Else cmdJustagewerte(Index).Visible = False End If Else cmdJustagewerte(Index).Visible = False End If '---------------------------------------------------- End Function '------------------------------------------------------ '------------------------------------------ Private Sub UeberpruefeAufPruefpunkte(Index As Integer) Dim Pruefzaehler As CPruefzaehler Set Pruefzaehler = m_colEinbauplatz.Item(Index).getPruefzaehler If Pruefzaehler Is Nothing Then Exit Sub End If If Pruefzaehler.getPruefpunkte Is Nothing Then Exit Sub End If If Pruefzaehler.getPruefpunkte.getPruefpunkteCount() = 0 Then DebugMsg "Pruefpunkte sind für diesen Zähler nicht definiert" If MsgBox("Dieser Zaehler enthält keine Prüfpunktdaten in der Datenbank. Möchten Sie jetzt Prüfpunkte eingeben?", vbYesNo) = vbYes Then Call imgZaehler_Click(Index) Else EntferneZaehlerAusEinbauplatz (Index) Exit Sub ' Alternativ: 'txtSerienNr(Index).BackColor = vbRed ' Fokus setzen, um ein Validate Event zu bekommen: txtSerienNr(Index).SetFocus End If Else If Pruefzaehler.getAuftragPositionSerienNr Is Nothing Then MsgBox ("AuftragPosSNr unbekannt") Else CheckWriteSerienNr (Index) End If End If End Sub Public Sub Hauptpruefung() Dim i As Integer Dim dlgHauptPruefung As frmUSHauptprf Dim blnPruefungDurchfuehren As Boolean Dim Einbauplatz As CEinbauplatz Set dlgHauptPruefung = New frmUSHauptprf Set m_Pruefgang = New CPruefgang Set dlgHauptPruefung.m_ParentForm = Me Set dlgHauptPruefung.m_colEinbauplatz = m_colEinbauplatz Set dlgHauptPruefung.m_colUniquePP = m_colUniquePP Set dlgHauptPruefung.m_colUniqueVorPP = m_colUniqueVorPP Set dlgHauptPruefung.m_Pruefgang = m_Pruefgang Set dlgHauptPruefung.m_RegulierPruefpunkt = m_colUniquePP.getPP(cmbPruefpunkte.text) dlgHauptPruefung.m_AnzahlPZ = Val(txtAnzahl.text) dlgHauptPruefung.mbln_Vorjustage = chkVorjustage.value dlgHauptPruefung.mbln_Hauptpruefung = chkHauptpruefung.value dlgHauptPruefung.mbln_Vorpruefung = chkVorpruefung.value dlgHauptPruefung.mbln_Bereichsjustage = chkBereichsjustage.value dlgHauptPruefung.mbln_nachjustage = chkNachjustage.value dlgHauptPruefung.mbln_ZeroFlowMessung = chkZeroflow.value dlgHauptPruefung.mbln_Funktionspruefung = chkFunktionsprüfung.value dlgHauptPruefung.mbln_HeissKaltSpreizungBerechnen = chkHeissKaltSpreizungBerechnen.value dlgHauptPruefung.mbln_ZeroFlowJustage = chkZeroFlowJustage.value If g_Abbruch Then Exit Sub ' Flags dlgHauptPruefung.m_bPruefgangLang = m_bPruefgangLang dlgHauptPruefung.m_Regelart = m_Regelart dlgHauptPruefung.m_PruefungsArtWaage = m_PruefungsArtWaage dlgHauptPruefung.m_VorPruefungsArtWaage = m_VorPruefungsArtWaage dlgHauptPruefung.m_NurMesseinsaetze = 0 dlgHauptPruefung.m_DauerpruefungAnzahl = CInt(txtAnzahlDauerPrf.text) dlgHauptPruefung.m_bKontinuierlich = chkKontinuierlich.value Timer1.Enabled = False blnPruefungDurchfuehren = False If chkNachjustage.value = vbChecked Then blnPruefungDurchfuehren = True If chkVorjustage.value = vbChecked Then blnPruefungDurchfuehren = True If chkVorpruefung.value = vbChecked Then blnPruefungDurchfuehren = True If chkKontinuierlich.value = vbChecked Then blnPruefungDurchfuehren = True If chkHauptpruefung.value = vbChecked Then blnPruefungDurchfuehren = True If chkFunktionsprüfung.value = vbChecked Then blnPruefungDurchfuehren = True If blnPruefungDurchfuehren = True Then frmMeldung.Show vbNormal, Me DoEvents frmMeldung.lblMsg.caption = "Prüfungsinitialisierung für alle eingebauten Zähler" frmMeldung.cmdIgnore.Enabled = False frmMeldung.cmdExit.Enabled = False frmMeldung.Visible = True DoEvents Call USPruefungInitialisierung Unload frmMeldung DoEvents Me.Visible = False dlgHauptPruefung.Show vbModal Me.Visible = True frmMeldung.Show vbNormal, Me DoEvents frmMeldung.lblMsg.caption = "Prüfungsabschluß für alle eingebauten Zähler" frmMeldung.cmdIgnore.Enabled = False frmMeldung.cmdExit.Enabled = False frmMeldung.Visible = True DoEvents Call USPruefungAbschlussAlleZaehler Unload frmMeldung If dlgHauptPruefung.getExitCode = IDOK Then 'MsgBox ("Die Prüfung wurde beendet.") Call PruefungFertigmeldenDialog("Die Prüfung ist beendet.", m_colEinbauplatz) Else MsgBox ("Die Prüfung wurde abgebrochen.") End If Else ' es fand keine Prüfung statt, da alle Checkbuttons ausgeschaltet sind End If DoEvents If g_App.Settings.GetAuslieferung() <> "" Then ' Auslieferungsprogramm ist in der ini angegegben If dlgHauptPruefung.getExitCode = IDOK Or blnPruefungDurchfuehren = False Then ' Wenn die Vor bzw. Hauptprüfung erfolgreich abgeschlossen wurde ' oder gar keine Prüfung durchgeführt wurde ' dann fragen, ob die Zähler abgeschlossen werden sollen Dim objFrmAuslieferung As frmAuslieferung Set objFrmAuslieferung = New frmAuslieferung Set objFrmAuslieferung.m_colEinbauplatz = m_colEinbauplatz objFrmAuslieferung.Show vbModal, Me ' Dim lngAusliefungAuswahl As Long ' lngAusliefungAuswahl = MsgBox("Möchten Sie jetzt das Programm 'Auslieferung'" & vbCrLf & "zum Verschließen für jeden Zähler jetzt starten?", vbYesNo Or vbDefaultButton2) ' If lngAusliefungAuswahl = vbYes Then ' For Each Einbauplatz In m_colEinbauplatz ' If Not Einbauplatz.getPruefzaehler Is Nothing Then ' Me.Visible = False ' Call StarteAuslieferung(Einbauplatz.getNr) ' Me.Visible = True ' End If ' Next ' End If End If End If ' Zähler entfernen, damit sie erneut eingelesen werden For i = 1 To g_App.Settings.EinbauplaetzeJeStrang txtSerienNr(i).text = "" imgSchloss(i).Picture = frmRes.ImgLeer.Picture ueberpruefe (i) Next If Not g_ohneSPS Then ' beide Behälter Ablassventile wieder schließen m_SPS.WassserAblassen 0 End If ' Scannen wieder einschalten, damit sie erneut eingelesen werden Timer1.Enabled = True End Sub Private Function SindZaehlerAehnlich() As Boolean ' Überprüfung ab alle Zähler gleich hinsichtlich: ' - Regulierwerte (Todo: Regulierwerte müssen aus Tabelle Sollwertregulierung bestimmt werden) ' - Nennweite ' - Zählertype ' - Anzeige (m^3) wenn Automatische Regulierung nicht gescheckt ' - Sollwert Regulierung (nur wenn Automatische Regulierung gecheckt) ' Todo: wie verfahren bei Mehrfacheinträgen z.B. m^3,RS,WI Wenn m^3 dann muß überall m^3 vorhanden sein, sonst muß gleich sein On Error Resume Next Dim Einbauplatz As CEinbauplatz Dim Pruefzaehler As CPruefzaehler Dim Pruefpunkte As CPruefpunkte Dim Pruefpunkt As CPruefpunkt Dim colUniquePP As New CPruefpunktCol Dim IdentNrObj As CIdentNr Dim AuftragPosition As CAuftragPosition Dim vergleich As String Dim ersterZaehler As Boolean Dim VergleichMuster As String ersterZaehler = True VergleichMuster = "" vergleich = "" SindZaehlerAehnlich = True ' Todo Exit Function For Each Einbauplatz In m_colEinbauplatz Set Pruefzaehler = Einbauplatz.getPruefzaehler() If Not Pruefzaehler Is Nothing Then Set IdentNrObj = Pruefzaehler.getIdentNrObj() Set AuftragPosition = Pruefzaehler.getAuftragPosition() Set Pruefpunkte = Pruefzaehler.getPruefpunkte If Not Pruefzaehler.getAuftrag.getNr = 99999 Then vergleich = "Nennweite=" & IdentNrObj.getNennweite & ";" vergleich = vergleich & "Type=" & IdentNrObj.getTyp & IdentNrObj.getTypzusatz & ";" vergleich = vergleich & "Anzeige=" & Mid(AuftragPosition.getAnzeige, 1, 3) & "; " ' vergleich = vergleich & "Impulswertigkeit=" & Pruefzaehler.GetImpulseQM Else ' Test-Pruefzaehler können nur mit anderen Test-Prüfzaehlern geprueft werden vergleich = "PRUEFZAEHLER" End If ' Alle weiteren Zaehler werden mit dem ersten verglichen If ersterZaehler Then VergleichMuster = vergleich Else ' DebugMsg "Vergleich " & Einbauplatz.getNr & ": " & vergleich & " =?= " & VergleichMuster ' unterscheidet sich ein Zähler vom ersten, sind die Zaehler nicht ähnlich ! If VergleichMuster <> vergleich Then SindZaehlerAehnlich = False End If End If End If ersterZaehler = False Next End Function Private Sub Timer1_Timer() Dim nIndex As Integer Dim alteFabNr As String Dim neueFabNr As String Dim tmpFlag As Boolean Dim lngRet As Long Dim alteFarbe As Long Dim blnSchlossOffen As Boolean Dim Einbauplatz As CEinbauplatz Dim AuftragpositionSerienNr As CAuftragPositionSerienNr Timer1.Enabled = False If mblnAbbruch = True Then Call Formularbeenden Exit Sub End If If m_TimerOn = False Then Exit Sub Shape1.BackColor = Shape1.BackColor Xor 255 For nIndex = 1 To g_App.Settings.EinbauplaetzeJeStrang Set Einbauplatz = m_colEinbauplatz(nIndex) If mblnAbbruch = True Then Call Formularbeenden Exit Sub End If alteFarbe = txtSerienNr(nIndex).BackColor txtSerienNr(nIndex).BackColor = &HE0E0E0 ' am Scannen DoEvents lblScanStat.caption = nIndex If USPing(nIndex) = 1 Then 'lblEinbau(nIndex).Caption = "US Zähler angeschlosssen!" ' Zähler antwortet txtSerienNr(nIndex).Enabled = True ' eingefügt am 24.07.2002 Pfeiffer cmdSerNrAusw(nIndex).Enabled = True DoEvents ' FabNr lesen neueFabNr = getUSFabNr(nIndex) lblStatus(nIndex) = "FabNr: " & neueFabNr lblTimeout(nIndex).caption = USgetOptoOffTimer(nIndex) & " min" If Val(neueFabNr) <> Val(Einbauplatz.getZusatz) Or txtSerienNr(nIndex) = "" Then ' neuer Zähler wurde erkannt Screen.MousePointer = vbHourglass lngRet = USSetOptoOffTimerMax(Einbauplatz.getNr) ' Schloss prüfen If Not USGetSchlossOffen(nIndex, blnSchlossOffen) Then If blnSchlossOffen Then imgSchloss(nIndex).Picture = frmRes.ImgSchlossOff Else imgSchloss(nIndex).Picture = frmRes.imgSchlossGes End If Else ' konnte Schloss nicht prüfen End If ' Überprüfung auf Rechenwerksnennweite Einbauplatz.intErkannteQp = Round(USGetFlowSimu(Einbauplatz.getNr) * 3600, 0) Debug.Print "Rechenwerksnennweite (FlowSimu) : " & Einbauplatz.intErkannteQp Einbauplatz.setZusatz neueFabNr Set AuftragpositionSerienNr = New CAuftragPositionSerienNr If Val(neueFabNr) > 0 Then ' FabNr ist vorhanden If AuftragpositionSerienNr.loadFromFabNr(CLng(neueFabNr)) Then 'AuftragPositionSNr wurde gefunden, Zähler war schon mal hier txtSerienNr(nIndex).text = FormatSerienNr(AuftragpositionSerienNr.getNr) ' Anzeigen der Auftragsdaten bTextChanged(nIndex) = True Call ueberpruefe(nIndex) DoEvents Call updatePruefpunkte DoEvents alteFarbe = txtSerienNr(nIndex).BackColor Else 'AuftragPositionSNr wurde nicht gefunden, Zähler ist noch unbekannt txtSerienNr(nIndex).text = const_keineSNText End If Else 'FabNr ist nicht vorhanden End If Screen.MousePointer = vbNormal Else ' Zähler ist vorhanden aber wurde bereits vorher erkannt bTextChanged(nIndex) = False End If Else EntferneZaehlerAusEinbauplatz (nIndex) Select Case g_lastPingFehler Case -4 ' keine Antowrt Case -1 ' kein Eintrag in Ini lblEinbau(nIndex).caption = "kein Verbindung zu COM" Case Else lblEinbau(nIndex).caption = "Fehler " & g_lastPingFehler End Select ' Zähler antwortet nicht, d.h. ' Zaehler wurde ausgebaut oder nicht wieder gescannt ' Einbauplatz.setZusatz "" ' txtSerienNr(nIndex).Text = "" ' Einbauplatz.setZusatz "" ' imgSchloss(nIndex).Picture = frmRes.ImgLeer.Picture ' ' txtSerienNr(nIndex).Enabled = False ' ' ' eingefügt am 24.07.2002 Pfeiffer ' cmdSerNrAusw(nIndex).Enabled = False ' lblStatus(nIndex) = "" ' ' ueberpruefe nIndex ' alteFarbe = vbWhite End If ' ping txtSerienNr(nIndex).BackColor = alteFarbe DoEvents Next Timer1.Enabled = m_TimerOn End Sub ' Prüft, ob Seriennr im Texteingabefeld von interner Seriennr abweicht ' fragt nach und schreibt eingegebene Seriennr in den Zähler Private Sub CheckWriteSerienNr(Index As Integer) Dim neueSernr As String Dim geleseneFabNr As String Dim Pruefzaehler As CPruefzaehler Dim AuftragpositionSerienNr As CAuftragPositionSerienNr Dim Einbauplatz As CEinbauplatz Dim comport As Integer Set Einbauplatz = m_colEinbauplatz(Index) Set Pruefzaehler = Einbauplatz.getPruefzaehler Set AuftragpositionSerienNr = Pruefzaehler.getAuftragPositionSerienNr geleseneFabNr = Einbauplatz.getZusatz If TestForQnIstOK(Einbauplatz) = False Then EntferneZaehlerAusEinbauplatz (Index) Exit Sub End If If AuftragpositionSerienNr.getFabNr <> geleseneFabNr Then If MsgBox("Möchten Sie diese Seriennr ('" & FormatSerienNr(Pruefzaehler.getSerienNr) & ") für diesen US-Zähler (FabNr: '" & geleseneFabNr & "') zukünftig verwenden?", vbYesNo, "") = vbYes Then If Not CheckAndCreateInSpeicherabbild(Einbauplatz.getNr, geleseneFabNr) Then MsgBox ("Speicherabbild wurde nicht gesichert.") Exit Sub End If comport = Val(g_App.Settings.getUSComPort(Index)) 'modIECCOM.SetLiegenschaft COMport, CLng(Pruefzaehler.getSerienNr) 'geändert Pfeiffer 10.09.2002 'modIECCOM.SetIdentNo COMport, CLng(Pruefzaehler.getSerienNr) AuftragpositionSerienNr.setFabNr CLng(geleseneFabNr) AuftragpositionSerienNr.save If UpdateInDruckpruefung(CLng(geleseneFabNr), Pruefzaehler.getSerienNr) = False Then Call MsgBox("Für diesen Zähler (FabNr=" & geleseneFabNr & ") liegen keine Ergebnisse der Druckprüfung vor!", vbCritical) LogIntoDB "Für diesen US Zähler (FabNr=" & geleseneFabNr & ") liegen keine Ergebnisse der Druckprüfung vor!", "Druckpruefung" End If Else 'geändert am 30.07.02 Pfeiffer EntferneZaehlerAusEinbauplatz (Index) End If End If End Sub Private Sub StartScan() cmdStopScan.caption = "Stop Scan" Timer1.Interval = 1000 Timer1.Enabled = True Shape1.BackColor = &H80FF& m_TimerOn = True End Sub Private Sub StopScan() cmdStopScan.caption = "Start Scan" Timer1.Enabled = False m_TimerOn = False Shape1.BackColor = 0 End Sub Private Sub USPruefungAbschlussAlleZaehler() Dim Einbauplatz As CEinbauplatz Dim Pruefzaehler As CPruefzaehler Dim EinbauplatzNr As Integer Dim comport As Integer Dim lngReturn As Long For Each Einbauplatz In m_colEinbauplatz If Not Einbauplatz.getPruefzaehler Is Nothing Then EinbauplatzNr = Einbauplatz.getNr Set Pruefzaehler = Einbauplatz.getPruefzaehler lngReturn = USPruefungsAbschluss(Einbauplatz.getNr) If lngReturn = 0 Then Debug.Print "Prüfungsabschluss für Einbauplatz " & EinbauplatzNr & " OK" Else Debug.Print "Fehler " & lngReturn & " beim Prüfungsabschluss für Einbauplatz " & EinbauplatzNr End If ' neu RH 8.12.2009 Dim AuftragPosition As CAuftragPosition Set AuftragPosition = Einbauplatz.getPruefzaehler.getAuftragPosition AuftragPosition.UpdateTLMenge_P AuftragPosition.save Einbauplatz.getPruefzaehler.getAuftrag End If Next End Sub Private Sub USPruefungInitialisierung() Dim Einbauplatz As CEinbauplatz Dim Pruefzaehler As CPruefzaehler Dim EinbauplatzNr As Integer Dim comport As Integer Dim lngReturn As Long m_colUniqueVorPP.sortQ m_colUniquePP.sortQ For Each Einbauplatz In m_colEinbauplatz If Not Einbauplatz.getPruefzaehler Is Nothing Then EinbauplatzNr = Einbauplatz.getNr Set Pruefzaehler = Einbauplatz.getPruefzaehler lngReturn = USZaehlerPruefungInitialisierung(Einbauplatz.getNr) If lngReturn = 0 Then DebugMsg "Prüfungsinitialisierung(" & EinbauplatzNr & ") OK" Else If lngReturn = -50 Then ErrorMsg "Schloss konnte nicht geöffnet werden am Einbauplatz " & EinbauplatzNr & "." & vbCrLf & "Schloss ist immer noch geschlossen!" Else ErrorMsg "Fehler " & lngReturn & " bei der Prüfungsinitialisierung, Einbauplatz " & EinbauplatzNr End If End If End If Next End Sub 'Private Function CheckAndCreateInSpeicherabbild(ByVal EinbauplatzNr As Integer, ByVal FabNr As Long) As Boolean 'Dim rs As CRecordset 'On Error GoTo CheckAndCreateInSpeicherabbildError ' 'TryAgain: ' Set rs = New CRecordset ' ' rs.openRS "SELECT * from Speicherabbild where FabNr = " & FabNr ' If rs.EOF Then ' rs.addNew ' Call rs.setValue("FabNr", FabNr) ' Call rs.setValue("Datum", Now()) ' Call rs.setValue("MemoryContent", "") ' ' If Not rs.update Then ' GoTo CheckAndCreateInSpeicherabbildError ' End If ' ' Debug.Print "Datensatz mit der FabFabNr " & FabNr & " in der Tabelle Speicherabbild erzeugt." ' Else ' Debug.Print "Datensatz mit der FabFabNr " & FabNr & " ist in der Tabelle Speicherabbild vorhanden." ' End If ' Set rs = Nothing ' CheckAndCreateInSpeicherabbild = True ' Exit Function ' 'CheckAndCreateInSpeicherabbildError: ' Debug.Print "CheckAndCreateInSpeicherabbild: " & Err.Description ' If MsgBox("FabNr '" & FabNr & "' konnte nicht in Tabelle Speicherabbild erzeugt werden. Fehler " & Err.Number & vbCrLf & Err.Description, vbRetryCancel Or vbDefaultButton1) = vbRetry Then ' Set rs = Nothing ' Resume TryAgain ' Else ' Set rs = Nothing ' Debug.Print "CheckAndCreateInSpeicherabbild abgebrochen." ' CheckAndCreateInSpeicherabbild = False ' End If 'End Function Private Function TestForQnIstOK(Einbauplatz As CEinbauplatz) As Boolean On Error GoTo Errorhandler Dim Pruefzaehler As CPruefzaehler Set Pruefzaehler = Einbauplatz.getPruefzaehler TestForQnIstOK = False If Einbauplatz.intErkannteQp <> 0 Then If Pruefzaehler.getVorpruefpunkte.load(Pruefzaehler.getIdentNr, Pruefzaehler.getPruefklasseKZ) = True Then If Einbauplatz.intErkannteQp <> Pruefzaehler.getVorpruefpunkte.getQn Then ErrorMsg "Die im Rechenwerk programmierte Rechenwerksnennweite (FP_Flow_Simu * 3600 = " & Einbauplatz.intErkannteQp & " m³/h) stimmt nicht mit in der Datenbank hinterlegten Qn=" & Pruefzaehler.getVorpruefpunkte.getQn & " m³/h aus der Tabelle Vorprüfpunkte überein!" & vbCrLf & "Der Zähler darf so nicht justiert und geprüft werden! Überprüfen Sie FP_Flow_Simu!" Else Debug.Print "OK: Die Rechenwerksnennweite " & Einbauplatz.intErkannteQp & " m³/h stimmt mit Qn aus der Tabelle Vorprüfpunkte überein!" TestForQnIstOK = True End If Else ErrorMsg "Die Vorprüfpunkte konnten nicht ermittelt werden für Prüfzähler SNr=" & FormatSerienNr(Pruefzaehler.getSerienNr) Exit Function End If Else ErrorMsg "Die Rechenwerksnennweite wurde nicht ermittelt" End If Exit Function Errorhandler: End Function Private Sub EntferneZaehlerAusEinbauplatz(Index As Integer) Dim Einbauplatz As CEinbauplatz Set Einbauplatz = m_colEinbauplatz(Index) Einbauplatz.setPruefzaehler Nothing imgSchloss(Index).Picture = frmRes.ImgLeer.Picture lblEinbau(Index).caption = "" lblTimeout(Index).caption = "" txtSerienNr(Index).BackColor = vbWhite imgZaehler(Index).Enabled = False txtSerienNr(Index).text = "" Einbauplatz.setZusatz "" cmdSerNrAusw(Index).Enabled = False lblStatus(Index) = "" txtSerienNr(Index).Enabled = True If txtSerienNr(Index).Enabled = True And txtSerienNr(Index).Visible = True Then On Error Resume Next txtSerienNr(Index).SetFocus On Error GoTo 0 End If txtSerienNr(Index).Enabled = False ueberpruefe Index End Sub Public Function HauptprfOffsetjustage2(ByVal lngSerienNr As Long, VorpruefpunkteCol As CVorpruefpunktCol, blnUsePruefstation As Boolean) As Boolean ' Justagedaten + Prüfpunkte einer Hauptprüf aktuellen Prüfstation in Qmin, Qmax oder QBereich Dim strSQL As String Dim rs As CRecordset Dim intHPPCount As Integer Set rs = New CRecordset strSQL = "SELECT Pruefgang.*, * FROM Prueffehler INNER JOIN Pruefgang ON Prueffehler.PruefgangNr = Pruefgang.PruefgangNr Where Prueffehler.SerienNr = " & lngSerienNr & " " If blnUsePruefstation Then strSQL = strSQL & " and Pruefgang.PruefstationNr = " & g_App.PruefstationNr End If strSQL = strSQL & " ORDER BY Prueffehler.PruefDatum DESC" Debug.Print strSQL rs.openRS strSQL Do While Not rs.EOF For intHPPCount = 1 To 10 If rs.getDoubleValue("PP" & intHPPCount & "_Soll") <> 0 Then If VorpruefpunkteCol.hasQ(rs.getDoubleValue("PP" & intHPPCount & "_Soll")) Then Debug.Print "Übereinst: HPF-VP Q=" & rs.getDoubleValue("PP" & intHPPCount & "_Soll") HauptprfOffsetjustage2 = True Exit Function End If End If Next rs.MoveNext Loop End Function Public Function HauptprfOffsetjustage(ByVal lngSerienNr As Long, Vorpruefpunkte As CVorpruefpunkte, blnUsePruefstation As Boolean) As Boolean ' Justagedaten + Prüfpunkte einer Hauptprüfung an dieser aktuellen Prüfstation in Qmin, Qmax oder QBereich Dim strSQL As String Dim rs As CRecordset Dim intHPPCount As Integer Dim intVPPCount As Integer Dim blnQminVorhanden As Boolean Dim blnQmaxVorhanden As Boolean Dim dtmDatum As Date Set rs = New CRecordset strSQL = "SELECT * from USJustagewerte where SerienNr = " & lngSerienNr rs.openRS strSQL If Not rs.EOF Then dtmDatum = rs.getDateValue("DatumVorpruefung") '1 Minute anziehen, damit der Vergleich klappt dtmDatum = DateAdd("n", -1, dtmDatum) If Val(dtmDatum) = 0 Then HauptprfOffsetjustage = False Exit Function End If Else Exit Function End If strSQL = "SELECT Pruefgang.*, Prueffehler.* FROM Prueffehler INNER JOIN Pruefgang ON Prueffehler.PruefgangNr = Pruefgang.PruefgangNr Where Prueffehler.SerienNr = " & lngSerienNr & " and Pruefgang.Datum >= CONVERT(smalldatetime, '" & Format(dtmDatum, "yyyy-mm-dd hh:mm:00") & "', 120)" If blnUsePruefstation Then strSQL = strSQL & " and Pruefgang.PruefstationNr = " & g_App.PruefstationNr End If strSQL = strSQL & " ORDER BY Prueffehler.PruefDatum DESC" Debug.Print strSQL rs.openRS strSQL If Not rs.EOF Then Debug.Print "Hauptprüfung am " & rs.getDateValue("Datum") For intHPPCount = 1 To 10 If rs.getDoubleValue("PP" & intHPPCount & "_Soll") <> 0 Then Debug.Print "teste HP =" & rs.getDoubleValue("PP" & intHPPCount & "_Soll") For intVPPCount = 3 To 1 Step -1 Debug.Print intVPPCount & "; VP: " & Vorpruefpunkte.getPruefpunkt(intVPPCount).getQ & " =?= " & CSng(rs.getDoubleValue("PP" & intHPPCount & "_Soll")) If CSng(Vorpruefpunkte.getPruefpunkt(intVPPCount).getQ) = CSng(rs.getDoubleValue("PP" & intHPPCount & "_Soll")) And Not rs.isFieldNull("PP" & intHPPCount & "_Fehler") Then Select Case intVPPCount Case 1 ' Qmax Debug.Print "Qmax übereinstimmung" blnQmaxVorhanden = True Case 2 ' QBereich Debug.Print "Qbereich übereinstimmung" Case 3 ' Q min Debug.Print "Qmin übereinstimmung" blnQminVorhanden = True End Select End If Next End If Next Else End If If blnQmaxVorhanden And blnQminVorhanden Then HauptprfOffsetjustage = True Else HauptprfOffsetjustage = False End If End Function Sub AlleEinbauplaetzeDesGleichenAuftragesAktualisieren(Index As Integer) Dim AuftragNr As Long Dim PositionNr As Long Dim PruefzaehlerAktuell As CPruefzaehler Dim PruefzaehlerVergleich As CPruefzaehler Dim Einbauplatz As CEinbauplatz Set PruefzaehlerAktuell = m_colEinbauplatz(Index).getPruefzaehler AuftragNr = PruefzaehlerAktuell.getAuftrag.getNr PositionNr = PruefzaehlerAktuell.getAuftragPosition.getNr For Each Einbauplatz In m_colEinbauplatz Set PruefzaehlerVergleich = Einbauplatz.getPruefzaehler If Not PruefzaehlerVergleich Is Nothing Then If PruefzaehlerAktuell.getAuftrag.getNr = PruefzaehlerVergleich.getAuftrag.getNr And PruefzaehlerAktuell.getAuftragPosition.getNr = PruefzaehlerVergleich.getAuftragPosition.getNr Then bTextChanged(Einbauplatz.getNr) = True Debug.Print "gleiche AuftragNr/PosNr in Einbauplatz " & Einbauplatz.getNr Call updateEinbauplatz(Einbauplatz.getNr) Call ueberpruefe(Einbauplatz.getNr) End If End If Next End Sub Private Sub Show50GradFehlerBeiQmin(Index As Integer) On Error GoTo Errorhandler Dim Pruefzaehler As CPruefzaehler Dim Einbauplatz As CEinbauplatz Dim rs As CRecordset Dim i As Integer Dim Fehler As Double Dim Vorpruefpunkte As CVorpruefpunkte Set Einbauplatz = m_colEinbauplatz.Item(Index) Set Pruefzaehler = Einbauplatz.getPruefzaehler If Pruefzaehler Is Nothing Then lblFehler50(Index).Visible = False Else Set Vorpruefpunkte = Pruefzaehler.getVorpruefpunkte If Vorpruefpunkte Is Nothing Then lblFehler50(Index).Visible = False Else If Vorpruefpunkte.LadeHeissesQMin(Pruefzaehler.getSerienNr, Pruefzaehler.getPruefpunkte.getPruefpunkt(Pruefzaehler.getPruefpunkte.getPruefpunkteCount).getQ, Fehler) Then lblFehler50(Index).Visible = True lblFehler50(Index).caption = Format(Fehler, "0.00") ' RH 12.08.2004 von 30% auf 10% heruntergesetzt If Abs(Fehler) > 10 Then lblFehler50(Index).BackColor = RGB(255, 160, 160) ' rot lblFehler50(Index).ToolTipText = "Fehler bei Qmin 50°C an der P20 übersteigt 10%" Else lblFehler50(Index).BackColor = RGB(160, 255, 160) ' grün lblFehler50(Index).ToolTipText = "Fehler bei Qmin 50°C an der P20" End If Else lblFehler50(Index).caption = "" lblFehler50(Index).BackColor = vbWhite End If End If End If Exit Sub Errorhandler: WriteToLog "Fehler " & Err.Number & " in Show50GradFehlerBeiQmin: " & Err.Description End Sub Private Sub StarteAuslieferung(EinbauplatzNr As Integer, Optional blnNacheinander As Boolean = True) On Error GoTo Errorhandler Dim strCOM As String Dim strKommando As String Dim lngHandle As Long Dim blnTimer As Boolean blnTimer = Timer1.Enabled Timer1.Enabled = False DoEvents strCOM = CStr(Val(g_App.Settings.getUSComPort(EinbauplatzNr))) strKommando = g_App.Settings.GetAuslieferung() If strKommando <> "" Then ExecuteAndWait strKommando, "/COM " & strCOM & " /EBP " & EinbauplatzNr & " /END", Me.hwnd, , blnNacheinander End If Timer1.Enabled = blnTimer Exit Sub Errorhandler: ErrorMsg "Fehler " & Err.Number & " in StarteAuslieferung(): " & Err.Description Timer1.Enabled = blnTimer End Sub