VERSION 5.00 Begin VB.Form frmTurbo2PruefzaehlerPruefung BackColor = &H8000000B& BorderStyle = 0 'Kein Caption = "Pruef2000" ClientHeight = 11520 ClientLeft = 105 ClientTop = 105 ClientWidth = 15240 HelpContextID = 1 Icon = "Turbo2PruefzaehlerPruefung.frx":0000 LinkTopic = "Form1" Moveable = 0 'False ScaleHeight = 11520 ScaleWidth = 15240 ShowInTaskbar = 0 'False StartUpPosition = 1 'Fenstermitte 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 = 11445 Left = 0 TabIndex = 12 Top = 0 Width = 13275 Begin VB.Frame Frame6 Caption = "Impulswertigkeit" Height = 795 Left = 5820 TabIndex = 104 Top = 9420 Width = 4035 End Begin VB.Frame frmPruefprotokollDrucken Caption = "Prüfprotokoll" Height = 735 Left = 10380 TabIndex = 101 Top = 9450 Width = 2655 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 = 300 TabIndex = 102 ToolTipText = "Aktivieren Sie diese Checkbox, um nach der Prüfung ein Protokoll zu drucken." Top = 210 Width = 2055 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 = 4605 Left = 10380 TabIndex = 28 Top = 1500 Width = 2715 Begin VB.ComboBox cmbWinkelDurchfluss Height = 315 Left = 420 TabIndex = 120 ToolTipText = "Auswahl des Durchflusses für die Winkelprüfung" Top = 3900 Width = 1695 End Begin VB.ComboBox cmbPruefpunkte Height = 315 Left = 390 Style = 2 'Dropdown-Liste TabIndex = 50 Top = 3120 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 = 1020 Left = 360 TabIndex = 29 Top = 1680 Width = 1695 End Begin VB.Label Label3 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Winkelprü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 = 150 TabIndex = 121 Top = 3600 Width = 1470 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 = 120 TabIndex = 49 Top = 2820 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 = 300 TabIndex = 33 Top = 540 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 = 120 TabIndex = 32 Top = 300 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 = 300 TabIndex = 31 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 = 120 TabIndex = 30 Top = 840 Width = 1995 End End Begin VB.Frame frEinbau BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 1095 Index = 1 Left = 570 TabIndex = 23 Top = 150 Width = 4000 Begin VB.CommandButton cmdRuecklaeuferanalyse Caption = "Rückläufer" Height = 225 Index = 1 Left = 2460 TabIndex = 109 Top = 810 Width = 945 End Begin VB.CommandButton cmdSerNrAusw Caption = "Snr." Height = 195 Index = 1 Left = 2010 TabIndex = 1 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 = 420 Index = 1 Left = 210 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 = 195 Index = 1 Left = 2010 TabIndex = 53 Top = 540 Width = 1935 End Begin VB.Label lblEinbau Caption = "1234abcdefghijklmnopqrstuvwxyz" Height = 375 Index = 1 Left = 240 TabIndex = 24 Top = 240 Width = 3675 End Begin VB.Image imgInfo Appearance = 0 '2D Height = 480 Index = 1 Left = 3480 Top = 600 Width = 480 End End Begin VB.Timer timer1 Enabled = 0 'False Left = 5400 Top = 240 End Begin VB.CommandButton cmdOK Caption = "Prüfung starten" DownPicture = "Turbo2PruefzaehlerPruefung.frx":000C Enabled = 0 'False 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 = 11280 TabIndex = 62 Top = 10440 Width = 1875 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 = 8550 TabIndex = 61 Top = 10440 Width = 1845 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 = 5550 TabIndex = 60 Top = 10470 Width = 1935 End Begin VB.Frame Frame4 Caption = "Prüfgang Nr" Height = 735 Left = 10380 TabIndex = 51 Top = 8580 Width = 2715 Begin VB.Label lblPruefgangNr BorderStyle = 1 'Fest Einfach Height = 285 Left = 810 TabIndex = 52 Top = 300 Width = 1635 End End Begin VB.Frame Frame1 Caption = "Regulierung" Height = 1095 Left = 5820 TabIndex = 43 Top = 2160 Width = 4035 Begin VB.ComboBox cmbSollFehler Height = 315 Left = 1260 Style = 2 'Dropdown-Liste TabIndex = 106 Top = 660 Width = 735 End Begin VB.CheckBox chkRegulierungDurchfuehren Caption = "automatische Regulierung" BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 195 Left = 450 TabIndex = 97 Top = 300 Value = 1 'Aktiviert Width = 3375 End Begin VB.Label Label5 Caption = "%" Height = 255 Left = 2100 TabIndex = 107 Top = 720 Width = 255 End Begin VB.Label Label4 Alignment = 1 'Rechts Caption = "SollFehler" Height = 255 Left = 300 TabIndex = 105 Top = 720 Width = 855 End End Begin VB.Frame frame3 Caption = "Optionen" Height = 6015 Left = 5850 TabIndex = 39 Top = 3300 Width = 4035 Begin VB.CheckBox chkWinkelmessung Caption = "Winkel messen" BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 555 Left = 300 TabIndex = 122 Top = 3780 Width = 3375 End Begin VB.CheckBox chkVersuch Caption = "Versuch-Prüfung" BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 555 Left = 300 TabIndex = 119 Top = 3420 Width = 3375 End Begin VB.CheckBox chkEichpruefvorgabenIgnorieren Caption = "Eichpruefvorgaben ignorieren" BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 555 Left = 300 TabIndex = 100 Top = 3000 Width = 3615 End Begin VB.CheckBox chkKontinuierlichePrf Caption = "nur Kontinuierliche Prüfung" BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 555 Left = 300 TabIndex = 99 Top = 2580 Width = 3255 End Begin VB.CheckBox chkRueckwaertsprf Caption = "Rückwärtsprüfung" BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 555 Left = 300 TabIndex = 98 Top = 2160 Width = 2415 End Begin VB.CheckBox chkRegulierungVerwenden Caption = "Reguliervorgabe = Fehlerwert" BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 555 Left = 300 TabIndex = 59 Top = 1710 Width = 3435 End 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 = 315 Index = 1 Left = 960 TabIndex = 47 Top = 4920 Width = 2685 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 = 315 Index = 0 Left = 960 TabIndex = 46 Top = 4590 Width = 2265 End Begin VB.TextBox txtAnzahlDauerPrf Enabled = 0 'False Height = 315 Left = 1890 TabIndex = 44 Text = "1" Top = 630 Width = 495 End Begin VB.CheckBox chkNurMesseinsaetze Caption = "Nur Meßeinsätze" 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 = 300 TabIndex = 42 ToolTipText = "Meßeinsätze" Top = 1500 Width = 2355 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 = 300 TabIndex = 41 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 = 300 TabIndex = 40 Top = 960 Width = 1995 End Begin VB.Label lblPrfArt Caption = "Prüfung mit:" 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 = 390 TabIndex = 48 Top = 4320 Width = 3255 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 = 45 Top = 660 Width = 915 End End Begin VB.Frame Frame2 Caption = "Regelart kommt raus" Height = 1875 Left = 10380 TabIndex = 36 Top = 6540 Visible = 0 'False 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 = 38 Top = 780 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 = 37 Top = 360 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 = 10380 TabIndex = 34 Top = 660 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 = 120 TabIndex = 35 Top = 360 Width = 2115 End End Begin VB.Frame frmScanner Caption = "Scanner Eingabe" Height = 1455 Left = 5820 TabIndex = 25 Top = 540 Width = 1935 Begin VB.CommandButton cmdStopScan Caption = "STOP SCAN" Height = 315 Left = 120 TabIndex = 108 Top = 540 Width = 1215 End 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 = 26 Top = 960 Width = 1575 End Begin VB.Label lblScanStat BackStyle = 0 'Transparent Caption = "x" BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 315 Left = 1500 TabIndex = 103 Top = 300 Width = 255 End Begin VB.Shape Shape1 BorderColor = &H00000000& BorderStyle = 2 'Strich BorderWidth = 2 FillColor = &H000080FF& FillStyle = 0 'Ausgefüllt Height = 435 Left = 1260 Shape = 3 'Kreis Top = 240 Width = 615 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 = 27 Top = 660 Width = 1575 End End Begin VB.Frame frEinbau BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 1095 Index = 2 Left = 570 TabIndex = 21 Top = 1140 Width = 4000 Begin VB.CommandButton cmdRuecklaeuferanalyse Caption = "Rückläufer" Height = 225 Index = 2 Left = 2430 TabIndex = 110 Top = 810 Width = 945 End Begin VB.CommandButton cmdSerNrAusw Caption = "Snr." Height = 195 Index = 2 Left = 1980 TabIndex = 3 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 = 2 Left = 210 TabIndex = 2 Top = 630 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 = 2 Left = 1980 TabIndex = 54 Top = 600 Width = 1695 End Begin VB.Image imgInfo Appearance = 0 '2D Height = 480 Index = 2 Left = 3480 Top = 600 Width = 480 End Begin VB.Label lblEinbau Caption = "1234abcdefghijklmnopqrstuvwxyz" Height = 225 Index = 2 Left = 210 TabIndex = 22 Top = 270 Width = 3675 End End Begin VB.Frame frEinbau BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 1095 Index = 3 Left = 570 TabIndex = 19 Top = 2130 Width = 4000 Begin VB.CommandButton cmdRuecklaeuferanalyse Caption = "Rückläufer" Height = 225 Index = 3 Left = 2460 TabIndex = 111 Top = 810 Width = 945 End Begin VB.CommandButton cmdSerNrAusw Caption = "Snr." Height = 195 Index = 3 Left = 1980 TabIndex = 5 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 = 3 Left = 270 TabIndex = 4 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 = 195 Index = 3 Left = 1980 TabIndex = 55 Top = 510 Width = 1935 End Begin VB.Image imgInfo Appearance = 0 '2D Height = 480 Index = 3 Left = 3480 Top = 600 Width = 480 End Begin VB.Label lblEinbau Caption = "1234abcdefghijklmnopqrstuvwxyz" Height = 255 Index = 3 Left = 240 TabIndex = 20 Top = 240 Width = 3675 End End Begin VB.Frame frEinbau BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 1095 Index = 4 Left = 570 TabIndex = 17 Top = 3120 Width = 3975 Begin VB.CommandButton cmdRuecklaeuferanalyse Caption = "Rückläufer" Height = 225 Index = 4 Left = 2430 TabIndex = 112 Top = 810 Width = 945 End Begin VB.CommandButton cmdSerNrAusw Caption = "Snr." Height = 195 Index = 4 Left = 1980 TabIndex = 7 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 = 4 Left = 240 TabIndex = 6 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 = 195 Index = 4 Left = 1980 TabIndex = 56 Top = 600 Width = 1935 End Begin VB.Image imgInfo Appearance = 0 '2D Height = 480 Index = 4 Left = 3480 Top = 600 Width = 480 End Begin VB.Label lblEinbau Caption = "1234abcdefghijklmnopqrstuvwxyz" Height = 285 Index = 4 Left = 240 TabIndex = 18 Top = 240 Width = 3675 End End Begin VB.Frame frEinbau BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 1095 Index = 5 Left = 570 TabIndex = 15 Top = 4110 Width = 4000 Begin VB.CommandButton cmdRuecklaeuferanalyse Caption = "Rückläufer" Height = 225 Index = 5 Left = 2430 TabIndex = 113 Top = 810 Width = 945 End Begin VB.CommandButton cmdSerNrAusw Caption = "Snr." Height = 195 Index = 5 Left = 1980 TabIndex = 9 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 = 240 TabIndex = 8 Top = 660 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 = 195 Index = 5 Left = 1980 TabIndex = 57 Top = 600 Width = 1935 End Begin VB.Image imgInfo Appearance = 0 '2D Height = 480 Index = 5 Left = 3480 Top = 600 Width = 480 End Begin VB.Label lblEinbau Caption = "1234abcdefghijklmnopqrstuvwxyz" Height = 375 Index = 5 Left = 120 TabIndex = 16 Top = 210 Width = 3675 End End Begin VB.Frame frEinbau BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 1095 Index = 6 Left = 570 TabIndex = 13 Top = 5100 Width = 4000 Begin VB.CommandButton cmdRuecklaeuferanalyse Caption = "Rückläufer" Height = 225 Index = 6 Left = 2460 TabIndex = 114 Top = 810 Width = 945 End Begin VB.CommandButton cmdSerNrAusw Caption = "Snr." Height = 195 Index = 6 Left = 1980 TabIndex = 11 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 = 240 TabIndex = 10 Top = 600 Width = 1695 End Begin VB.Label lblEinbau Caption = "1234abcdefghijklmnopqrstuvwxyz" Height = 285 Index = 6 Left = 210 TabIndex = 14 Top = 240 Width = 3555 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 = 1980 TabIndex = 58 Top = 570 Width = 1935 End Begin VB.Image imgInfo Appearance = 0 '2D Height = 480 Index = 6 Left = 3480 Top = 600 Width = 480 End End Begin VB.Frame frEinbau BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 1095 Index = 7 Left = 570 TabIndex = 64 Top = 6090 Width = 4000 Begin VB.CommandButton cmdRuecklaeuferanalyse Caption = "Rückläufer" Height = 225 Index = 7 Left = 2430 TabIndex = 115 Top = 810 Width = 945 End Begin VB.CommandButton cmdSerNrAusw Caption = "Snr." Height = 195 Index = 7 Left = 1980 TabIndex = 66 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 = 7 Left = 240 TabIndex = 65 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 = 195 Index = 7 Left = 1980 TabIndex = 68 Top = 540 Width = 1935 End Begin VB.Image imgInfo Appearance = 0 '2D Height = 480 Index = 7 Left = 3480 Top = 600 Width = 480 End Begin VB.Label lblEinbau Caption = "1234abcdefghijklmnopqrstuvwxyz" Height = 285 Index = 7 Left = 240 TabIndex = 67 Top = 210 Width = 3675 End End Begin VB.Frame frEinbau BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 1125 Index = 8 Left = 570 TabIndex = 69 Top = 7080 Width = 4000 Begin VB.CommandButton cmdRuecklaeuferanalyse Caption = "Rückläufer" Height = 225 Index = 8 Left = 2460 TabIndex = 116 Top = 840 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 = 8 Left = 240 TabIndex = 71 Top = 660 Width = 1695 End Begin VB.CommandButton cmdSerNrAusw Caption = "Snr." Height = 195 Index = 8 Left = 1980 TabIndex = 70 Top = 870 Width = 405 End Begin VB.Label lblEinbau Caption = "1234abcdefghijklmnopqrstuvwxyz" Height = 315 Index = 8 Left = 240 TabIndex = 73 Top = 210 Width = 3675 End Begin VB.Image imgInfo Appearance = 0 '2D Height = 480 Index = 8 Left = 3480 Top = 630 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 = 255 Index = 8 Left = 1980 TabIndex = 72 Top = 630 Width = 1935 End End Begin VB.Frame frEinbau BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 1095 Index = 9 Left = 570 TabIndex = 74 Top = 8130 Width = 4000 Begin VB.CommandButton cmdRuecklaeuferanalyse Caption = "Rückläufer" Height = 225 Index = 9 Left = 2460 TabIndex = 117 Top = 810 Width = 945 End Begin VB.CommandButton cmdSerNrAusw Caption = "Snr." Height = 195 Index = 9 Left = 1980 TabIndex = 76 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 = 9 Left = 240 TabIndex = 75 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 = 195 Index = 9 Left = 1980 TabIndex = 78 Top = 600 Width = 1935 End Begin VB.Image imgInfo Appearance = 0 '2D Height = 480 Index = 9 Left = 3480 Top = 600 Width = 480 End Begin VB.Label lblEinbau Caption = "1234abcdefghijklmnopqrstuvwxyz" Height = 285 Index = 9 Left = 270 TabIndex = 77 Top = 180 Width = 3675 End End Begin VB.Frame frEinbau BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 1095 Index = 10 Left = 570 TabIndex = 89 Top = 9150 Width = 4000 Begin VB.CommandButton cmdRuecklaeuferanalyse Caption = "Rückläufer" Height = 225 Index = 10 Left = 2430 TabIndex = 118 Top = 810 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 = 10 Left = 240 TabIndex = 91 Top = 600 Width = 1695 End Begin VB.CommandButton cmdSerNrAusw Caption = "Snr." Height = 195 Index = 10 Left = 1980 TabIndex = 90 Top = 810 Width = 405 End Begin VB.Image imgInfo Appearance = 0 '2D Height = 480 Index = 10 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 = 195 Index = 10 Left = 2010 TabIndex = 92 Top = 570 Width = 1935 End Begin VB.Label lblEinbau Caption = "1234abcdefghijklmnopqrstuvwxyz" Height = 285 Index = 10 Left = 240 TabIndex = 93 Top = 210 Width = 3675 End End Begin VB.Frame Frame5 Caption = "Servo/FU Voreinstellwert" Height = 1095 Left = 7800 TabIndex = 94 Top = 540 Width = 2055 Begin VB.ComboBox cmbAnzahlZaehler Height = 315 Left = 1080 Style = 2 'Dropdown-Liste TabIndex = 95 Top = 450 Width = 615 End Begin VB.Label Label2 Caption = "Anzahl der Prüfzähler" Height = 495 Left = 120 TabIndex = 96 Top = 360 Width = 915 End End Begin VB.Image imgSchloss Height = 375 Index = 10 Left = 5280 Top = 9840 Width = 375 End Begin VB.Image imgSchloss Height = 375 Index = 9 Left = 5280 Top = 8820 Width = 375 End Begin VB.Image imgSchloss Height = 375 Index = 8 Left = 5280 Top = 7800 Width = 375 End Begin VB.Image imgSchloss Height = 375 Index = 7 Left = 5280 Top = 6780 Width = 375 End Begin VB.Image imgSchloss Height = 375 Index = 6 Left = 5280 Top = 5820 Width = 375 End Begin VB.Image imgSchloss Height = 375 Index = 5 Left = 5280 Top = 4800 Width = 375 End Begin VB.Image imgSchloss Height = 375 Index = 4 Left = 5280 Top = 3840 Width = 375 End Begin VB.Image imgSchloss Height = 375 Index = 3 Left = 5280 Top = 2820 Width = 375 End Begin VB.Image imgSchloss Height = 375 Index = 2 Left = 5280 Top = 1860 Width = 375 End Begin VB.Image imgSchloss Height = 375 Index = 0 Left = 4980 Top = 240 Width = 375 End Begin VB.Image imgSchloss Height = 375 Index = 1 Left = 5340 Top = 840 Width = 375 End Begin VB.Image imgZaehler Height = 630 Index = 10 Left = 4650 MousePointer = 99 'Benutzerdefiniert Top = 9600 Width = 615 End Begin VB.Label lblEbpNr 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 = 88 Top = 9660 Width = 375 End Begin VB.Label lblEbpNr 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 = 210 TabIndex = 87 Top = 8700 Width = 285 End Begin VB.Label lblEbpNr 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 = 210 TabIndex = 86 Top = 7710 Width = 285 End Begin VB.Label lblEbpNr 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 = 210 TabIndex = 85 Top = 6690 Width = 285 End Begin VB.Label lblEbpNr 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 = 210 TabIndex = 84 Top = 5670 Width = 285 End Begin VB.Label lblEbpNr 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 = 210 TabIndex = 83 Top = 4710 Width = 285 End Begin VB.Label lblEbpNr 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 = 210 TabIndex = 82 Top = 3690 Width = 285 End Begin VB.Label lblEbpNr 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 = 210 TabIndex = 81 Top = 2700 Width = 285 End Begin VB.Label lblEbpNr 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 = 210 TabIndex = 80 Top = 1710 Width = 285 End Begin VB.Label lblEbpNr 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 = 240 TabIndex = 79 Top = 720 Width = 285 End Begin VB.Image imgZaehler Height = 630 Index = 9 Left = 4650 MousePointer = 99 'Benutzerdefiniert Top = 8580 Width = 615 End Begin VB.Image imgZaehler Height = 630 Index = 8 Left = 4650 MousePointer = 99 'Benutzerdefiniert Top = 7560 Width = 615 End Begin VB.Image imgZaehler Height = 630 Index = 7 Left = 4650 MousePointer = 99 'Benutzerdefiniert Top = 6540 Width = 615 End Begin VB.Label lblTitle Caption = "Prüfvorbereitung Turbo2e" BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 435 Left = 5760 TabIndex = 63 Top = 180 Width = 10695 End Begin VB.Image imgZaehler Height = 630 Index = 1 Left = 4680 MousePointer = 99 'Benutzerdefiniert Top = 600 Width = 615 End Begin VB.Image imgZaehler Height = 630 Index = 2 Left = 4680 MousePointer = 99 'Benutzerdefiniert Top = 1620 Width = 615 End Begin VB.Image imgZaehler Height = 630 Index = 3 Left = 4650 MousePointer = 99 'Benutzerdefiniert Top = 2580 Width = 615 End Begin VB.Image imgZaehler Height = 630 Index = 4 Left = 4650 MousePointer = 99 'Benutzerdefiniert Top = 3570 Width = 615 End Begin VB.Image imgZaehler Height = 630 Index = 5 Left = 4650 MousePointer = 99 'Benutzerdefiniert Top = 4560 Width = 615 End Begin VB.Image imgZaehler Height = 630 Index = 6 Left = 4650 MousePointer = 99 'Benutzerdefiniert Top = 5520 Width = 615 End End End Attribute VB_Name = "frmTurbo2PruefzaehlerPruefung" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False '============================================================================== ' ' File : Turbo2PruefzaehlerPruefung.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_Regulierdaten As CRegulierdaten Private m_nEinbauplatz As Integer Private m_nSeriennummer As Long Private m_Regelart As String Private m_PruefungsArtWaage As Boolean Private m_bDauerpruefung As Boolean Private m_bPruefgangLang As Boolean ' neu eingefügt am 02.08.02 Pfeiffer Private m_Zaehlerart As String Private m_objSensusIFInterface As SensusIF2.Interface Private m_blnIsInTimer As Boolean Private m_blnIsInSensusIF As Boolean Private m_blnDoStart As Boolean Private m_Pruefgang As CPruefgang Public m_SPS As CSPS Dim bTextChanged(10) As Boolean Dim bBlinkend(10) As Boolean Dim mblnAbbruch As Boolean ' Abbruch beim Scannen Dim m_TimerOn As Boolean ' bei DoEvents nicht 2 mal in Timer Routine springen Const const_keineSNText As String = "keine SNr" Const TEXTOHNEWINKELPP = "ohne" 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 chkKontinuierlichePrf_Click() If chkKontinuierlichePrf.value = vbChecked Then OptPrfArt(1).value = True OptPrfArt(0).value = False OptPrfArt(0).Enabled = False OptPrfArt(1).Enabled = False chkRegulierungDurchfuehren.value = vbUnchecked chkRegulierungDurchfuehren.Enabled = False Else chkRegulierungDurchfuehren.Enabled = True OptPrfArt(0).Enabled = True OptPrfArt(1).Enabled = True 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 Sub chkRegulierung_Click() ''disable cmdRegulierdaten ' If chkRegulierung.Value = 1 And chkRegulierung.Enabled Then ' cmdVorgaben.Enabled = True ' Else ' cmdVorgaben.Enabled = 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 chkRegulierungDurchfuehren_Click() If chkRegulierungDurchfuehren.value = vbChecked Then cmbSollFehler.Enabled = True Else cmbSollFehler.Enabled = False End If End Sub Private Sub chkVersuch_Click() If chkVersuch.value = vbChecked Then g_blnVersuch = True Else g_blnVersuch = False End If End Sub Private Sub chkWinkelmessung_Click() If chkWinkelmessung.value = vbChecked Then cmbWinkelDurchfluss.Enabled = True Else cmbWinkelDurchfluss.Enabled = False End If End Sub Private Sub cmbSollFehler_Click() On Error GoTo Errorhandler Dim Nennweite As Integer Dim Regulierwert As Double Regulierwert = CDbl(cmbSollFehler.text) Dim Einbauplatz As CEinbauplatz Dim Pruefzaehler As CPruefzaehler If Not m_colEinbauplatz Is Nothing Then For Each Einbauplatz In m_colEinbauplatz If Not Einbauplatz.getPruefzaehler Is Nothing Then Nennweite = Einbauplatz.getPruefzaehler.getAuftragPosition.getIdentNrObj.getNennweite ' speichern in ini g_App.Settings.SetRegulierWertTurbo2e "Turbo2eRegulierWert" & CStr(Nennweite), CStr(Regulierwert) End If Next End If Errorhandler: End Sub Private Sub initCmbSollFehler(Nennweite As Long) Dim dblRegulierwert As Double Dim i As Integer dblRegulierwert = g_App.Settings.GetRegulierWertTurbo2e("Turbo2eRegulierWert" & CStr(Nennweite)) For i = -120 To 120 Debug.Print i / 10 If CDbl(i / 10) = dblRegulierwert Then cmbSollFehler.ListIndex = i + 120 End If Next End Sub ' Neu eingefügt am 02.08.02 Pfeiffer Private Sub cmdSerNrAusw_Click(Index As Integer) cmdSerNrAusw(Index).Enabled = False txtSerienNr_DblClick (Index) cmdSerNrAusw(Index).Enabled = True 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 Form_Load() Dim i As Integer Dim nLeft As Long Dim nTop As Long Call initEinbauplaetze ' Erzeuge Einbauplaetze Collection 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 For i = -120 To 120 cmbSollFehler.AddItem i / 10 Next cmbSollFehler.ListIndex = cmbSollFehler.ListCount / 2 Set m_SPS = g_App.getSPS() Set m_Regulierdaten = New CRegulierdaten For i = 1 To 10 lblEinbau(i).caption = "" cmdRuecklaeuferanalyse(i).Enabled = False 'txtSerienNr(i).Left = txtSerienNr(1).Left 'txtSerienNr(i).Top = txtSerienNr(1).Top 'txtSerienNr(i).Width = txtSerienNr(1).Width 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 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 imgZaehler(i).Picture = frmRes.imgZaehlerGrauLinks.Picture txtSerienNr(i).MaxLength = 10 imgZaehler(i).Enabled = False If i <= g_App.Settings.EinbauplaetzeJeStrang Then Else frEinbau(i).Visible = False imgZaehler(i).Visible = False End If Next i 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 lblPruefer = g_App.Mitarbeiter().getVorname() & " " & g_App.Mitarbeiter().getName() lblUniquePP = 0 lblMaxPP = g_App.Settings.getMaxPruefpunkte() lblTitle = "Prüfvorbereitung Turbo2e" chkRegulierungVerwenden.value = g_App.Settings.RegulierungVerwenden ' neu RH 13.12.2004 If g_App.Settings.EichpruefvorgabenIgnorieren <> "0" And g_App.Settings.EichpruefvorgabenIgnorieren <> "1" Then chkEichpruefvorgabenIgnorieren.Visible = False Else chkEichpruefvorgabenIgnorieren.Visible = True If g_App.Settings.EichpruefvorgabenIgnorieren = "1" Then chkEichpruefvorgabenIgnorieren.value = vbChecked Else chkEichpruefvorgabenIgnorieren.value = vbUnchecked End If End If chkProtokolldruck_Click ' chkKeineRegulierung.Value = g_App.Settings.Ueberspringen ' Call chkKeineRegulierung_Click ' Initialisierung der RadioButtons "PruefungsArt" Select Case g_App.Settings.PruefungsArt 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 'if g_App. 'cmdOK.Enabled = False g_frmMain.Hide Call initRegelart ' Pruefgang Objekt erzeugen / Pruefgang starten Set m_Pruefgang = New CPruefgang Call InitCmbAnzahlZaehler If chkVersuch.value = vbChecked Then chkRegulierungDurchfuehren.value = vbUnchecked End If chkWinkelmessung_Click 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) Set m_objSensusIFInterface = Nothing g_frmMain.Show End Sub '------------------------------------------------------------------------------ ' Event-Handling '------------------------------------------------------------------------------ Private Sub cmdCancel_Click() mblnAbbruch = True If m_blnIsInSensusIF Then Exit Sub If m_blnIsInTimer Then Exit Sub Call endDialog(IDCANCEL) End Sub ' Vorgabe der Prüfgangvorgaben ' 'Private Sub cmdVorgaben_Click() ' Dim dlg As frmPruefgangVorgaben ' Me.MousePointer = vbHourglass ' Set dlg = New frmPruefgangVorgaben ' Call dlg.setRegulierdaten(m_Regulierdaten) ' If doModal(dlg, True) = IDOK Then ' End If ' Me.MousePointer = vbDefault '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 ' ZeigePruefpunkte (Index) If g_MetrologAktualisieren = True Then AlleEinbauplaetzeDesGleichenAuftragesAktualisieren (Index) Else Call ueberpruefe(Index) End If updatePruefpunkte End If Me.MousePointer = vbDefault 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 ' 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 '' Nur numerische Eingaben zulassen 'Private Sub txtImpulswertigkeitPZ_KeyPress(KeyAscii As Integer) ' If Not IsNumeric(Chr$(KeyAscii)) Then ' If KeyAscii <> 8 Then KeyAscii = 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) selectSerienNrField (Index) StopScan End Sub Private Sub txtSerienNr_DblClick(Index As Integer) Dim frmDialog As frmSeriennrAuswahl Dim i As Integer If m_colEinbauplatz(Index).getZusatz <> "" Then txtSerienNr(Index).Enabled = False Set frmDialog = New frmSeriennrAuswahl For i = 1 To 10 g_Seriennr(i) = txtSerienNr(i) Next If m_TimerOn = True Then DisableEventsForSensusIF (Index) frmDialog.Show vbModal, Me EnableEventsForSensusIF (Index) Else frmDialog.Show vbModal, Me End If txtSerienNr(Index).Enabled = True If IsNumeric(frmDialog.sSerienNr) Then txtSerienNr(Index).text = frmDialog.sSerienNr bTextChanged(Index) = True txtSerienNr(Index).SetFocus ueberpruefe (Index) End If 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 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) End If If KeyCode = 38 Then ' Setzt Fokus ins darüberliegende Textfeld bei Cursor-Up If txtSerienNr(IIf(Index > 1, Index - 1, g_App.Settings.EinbauplaetzeJeStrang)).Enabled = True Then txtSerienNr(IIf(Index > 1, Index - 1, g_App.Settings.EinbauplaetzeJeStrang)).SetFocus End If ueberpruefe (Index) End If End Sub Private Sub txtSerienNr_KeyPress(Index As Integer, KeyAscii As Integer) 'If KeyAscii = 13 Then ' txtSerienNr(IIf(Index < g_App.Settings.EinbauplaetzeJeStrang, Index + 1, 1)).SetFocus ' ueberpruefe (Index) 'End If If KeyAscii = 13 Then ueberpruefe (Index) StartScan 'Geändert am 10.08.02 Pfeiffer If Index < g_App.Settings.EinbauplaetzeJeStrang Then Index = Index + 1 Else Index = 1 End If If cmdSerNrAusw(Index).Enabled = True Then cmdSerNrAusw(Index).SetFocus End If End If If Not IsNumeric(Chr$(KeyAscii)) Then If KeyAscii <> 8 Then KeyAscii = 0 End If End Sub Private Sub ZeigePruefpunkte(Index As Integer) Dim Pruefzaehler As CPruefzaehler Dim Pruefpunkte As CPruefpunkte Dim Pruefpunkt As CPruefpunkt Set Pruefzaehler = m_colEinbauplatz(Index).getPruefzaehler If Pruefzaehler Is Nothing Then MsgBox ("Prüfzahler is nothing") Else Set Pruefpunkte = Pruefzaehler.getPruefpunkte If Pruefpunkte Is Nothing Then MsgBox ("Pruefpunkte is nothing") Else For Each Pruefpunkt In Pruefpunkte.getPruefpunkte.getCollection MsgBox Pruefpunkt.getQ Next End If 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 ' Validierung bei Fokus Wechsel in ein anderes Feld per Maus Private Sub txtSerienNr_Validate(Index As Integer, Cancel As Boolean) 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 txtSerienNr(Index).text = "" txtSerienNr(Index).SetFocus 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 ' raise 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.getPruefpunkteCount > 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) DebugMsg "Überprüfe SerienNr " & txtSerienNr(Index) If bTextChanged(Index) = True Then bTextChanged(Index) = False If txtSerienNr(Index).text = "0" Then ErstelleTestPruefzaehler (Index) ueberpruefe (Index) Exit Sub Else 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 Else ' SerienNr wurde nicht akzeptiert If txtSerienNr(Index).Enabled = True Then txtSerienNr(Index).SetFocus End If 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 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) ' Anzeige der eindeutigen Prüfpunkte aktualisieren lblUniquePP = m_colUniquePP.Count ' Listboxen für Pruefpunkte aktualisieren lstPruefpunkte.Clear cmbPruefpunkte.Clear cmbWinkelDurchfluss.Clear m_colUniquePP.sortQ For i = 1 To m_colUniquePP.Count() lstPruefpunkte.AddItem m_colUniquePP.Item(i).getQ cmbPruefpunkte.AddItem m_colUniquePP.Item(i).getQ cmbWinkelDurchfluss.AddItem m_colUniquePP.Item(i).getQ Next i cmbPruefpunkte.AddItem "ohne" cmbWinkelDurchfluss.AddItem TEXTOHNEWINKELPP cmbWinkelDurchfluss.ListIndex = 0 If m_colUniquePP.Count() > 0 Then cmbPruefpunkte.ListIndex = 0 End If ' 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 If bKeinPruefzaehler Then ' Keine Seriennummer mehr vorhanden: ' Feld für Impulswertigkeit löschen ' txtImpulswertigkeitPZ.text = "" ' Globale Regulierdaten werden gelöscht, wenn ' keine SerienNr mehr vorhanden ist Set m_Regulierdaten = Nothing End If 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 '---------- Textfeld Impulswertigkeit Set Pruefzaehler = Einbauplatz.getPruefzaehler 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") Else Set m_Regulierdaten = Pruefpunkte.getRegulierdaten End If End If Call updatePruefpunkte GoTo testSerienNrInputReturn testSerienNrInputReturnFalse: Call selectSerienNrField(Index) Call updateZaehlerImage(Index) If txtSerienNr(Index).Enabled = True Then txtSerienNr(Index).SetFocus End If 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 ' 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 ' Prüfen, ob eine Auftragsposition existiert If Pruefzaehler.loadForSerienNr(lSerienNr) Then ' Prüfzähler vorhanden 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) DebugMsg "Prüfzähler mit SerienNr " & lSerienNr & " am Einbauplatz " & Einbauplatz.getNr 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 ' @return true = Keine Fehlerbedingung festgestellt ' Private Function updateEinbauplatz(Index As Integer) As Boolean On Error Resume Next Dim Einbauplatz As CEinbauplatz Dim StatusFertigung As Integer 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 'geändert am 14.02.2003 Pf, der letzte eigegebene Zähler bestimmt den Status "nur Messeinsätze" JA/NEIN If Trim(Pruefzaehler.getIdentNrObj.GetKurzBezeichnung) <> "ME" Then chkNurMesseinsaetze.value = 0 Else chkNurMesseinsaetze.value = 1 End If 'RH 16.11.2005 Call initCmbSollFehler(Pruefzaehler.getIdentNrObj.getNennweite) 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) = "" 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." txtSerienNr(Index).BackColor = vbYellow 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 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() Set m_Pruefgang = New CPruefgang Dim dlgHauptPruefung As frmTurbop2eHauptprf Set dlgHauptPruefung = New frmTurbop2eHauptprf Set dlgHauptPruefung.m_ParentForm = Me Set dlgHauptPruefung.m_colEinbauplatz = m_colEinbauplatz Set dlgHauptPruefung.m_colUniquePP = m_colUniquePP Set dlgHauptPruefung.m_Regulierdaten = m_Regulierdaten ' dlgHauptPruefung.m_bKeineRegulierung = CBool(chkKeineRegulierung.Value) Set dlgHauptPruefung.m_Pruefgang = m_Pruefgang If cmbWinkelDurchfluss.text <> TEXTOHNEWINKELPP Then dlgHauptPruefung.m_dblWinkelQ = CDbl(cmbWinkelDurchfluss.text) Else dlgHauptPruefung.m_dblWinkelQ = 0 End If Set dlgHauptPruefung.m_RegulierPruefpunkt = m_colUniquePP.getPP(cmbPruefpunkte.text) ' Flags dlgHauptPruefung.m_bPruefgangLang = m_bPruefgangLang dlgHauptPruefung.m_Regelart = m_Regelart dlgHauptPruefung.m_PruefungsArtWaage = m_PruefungsArtWaage dlgHauptPruefung.m_NurMesseinsaetze = (chkNurMesseinsaetze.value = 1) dlgHauptPruefung.m_DauerpruefungAnzahl = CInt(txtAnzahlDauerPrf.text) dlgHauptPruefung.m_RegulierungVerwenden = CInt(chkRegulierungVerwenden.value = 1) dlgHauptPruefung.m_bRegulierungDurchfuehren = CBool(chkRegulierungDurchfuehren.value = vbChecked) dlgHauptPruefung.m_blnRueckwaertspruefung = CBool(chkRueckwaertsprf.value = vbChecked) dlgHauptPruefung.m_bKontinuierlich = CBool(chkKontinuierlichePrf.value = vbChecked) dlgHauptPruefung.m_bEichpruefvorgabenIgnorieren = CBool(chkEichpruefvorgabenIgnorieren.value = vbChecked) dlgHauptPruefung.m_Regulierwert = CDbl(cmbSollFehler.text) dlgHauptPruefung.m_blnDoWinkelmessung = CBool(chkWinkelmessung.value = vbChecked) dlgHauptPruefung.Show vbModal Set m_Pruefgang = dlgHauptPruefung.m_Pruefgang If dlgHauptPruefung.getExitCode = IDOK Then ' Prüfung erfolgreich abgeschlossen ' MsgBox ("Pruefung beendet") Else If m_Pruefgang.PruefgangNr > 0 Then If g_blnVersuch Then m_Pruefgang.Bemerkung = m_Pruefgang.Bemerkung & " Abbruch" m_Pruefgang.save Else m_Pruefgang.saveAbgebrochenen m_Pruefgang.delete Set m_Pruefgang = Nothing LadeAuftragPositionSerienNrNeu m_colEinbauplatz End If ' ' Hier könnte der Pruefgang gelöscht werden. ' If MsgBox("Sie haben die Pruefung abgebrochen." & vbCrLf & "Möchten Sie die Ergebnisse des abgebrochenen Pruefganges (PruefgangNr=" & m_Pruefgang.PruefgangNr & ") löschen?", vbYesNo Or vbDefaultButton2, "Pruefgang abgebrochen") = vbYes Then ' m_Pruefgang.saveAbgebrochenen ' m_Pruefgang.delete ' LadeAuftragPositionSerienNrNeu m_colEinbauplatz ' Else ' m_Pruefgang.save ' End If Else ' hier gibt es keinen Prüfgang zum löschen End If End If chkRueckwaertsprf.value = vbUnchecked 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 Regulierdaten As CRegulierdaten 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 Set Regulierdaten = New CRegulierdaten Call Regulierdaten.load(IdentNrObj.getNr, Pruefpunkte.getPruefklasseKZ) If Not Pruefzaehler.getAuftrag.getNr = 99999 Then vergleich = "Nennweite=" & IdentNrObj.getNennweite & ";" vergleich = vergleich & "Type=" & IdentNrObj.getTyp & IdentNrObj.getTypzusatz & ";" ' If chkRegulierung.Value = vbChecked Then ' vergleich = vergleich & "Anzeige=" & Mid(AuftragPosition.getAnzeige, 1, 3) & "; " ' Else vergleich = vergleich & "Sollwert=" & Regulierdaten.getSPSSollwertRegulierung & ";" ' End If ' 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 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 InitCmbAnzahlZaehler() Dim i As Integer For i = 0 To 10 cmbAnzahlZaehler.AddItem CStr(i) Next cmbAnzahlZaehler.ListIndex = g_App.Settings.GetAnzahlFuerVoreinstellwert End Sub Private Sub cmbAnzahlZaehler_Click() g_App.Settings.SetAnzahlFuerVoreinstellwert cmbAnzahlZaehler.ListIndex End Sub '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub Formularbeenden() Dim Einbauplatz As CEinbauplatz Dim lngRet As Long cmdCancel.Enabled = True Call StopScan Call endDialog(IDCANCEL) End Sub Private Sub StopScan() Timer1.Enabled = False m_TimerOn = False Shape1.BackColor = 0 cmdStopScan.caption = "START SCAN" End Sub Private Sub Timer1_Timer() Dim nIndex As Integer Dim Einbauplatz As CEinbauplatz Dim alteFarbe As Long Dim comport As Integer Dim AuftragpositionSerienNr As CAuftragPositionSerienNr Dim strAntwort As String Dim lngSuccess As Long Dim neueFabNr As String Dim blnSchlossOffen As Boolean If m_blnIsInTimer = True Then ' Timer Event wird bereits ausgeführt m_blnIsInTimer = False Exit Sub End If ' Timer Events verhindern If Timer1.Enabled = False Then m_blnIsInTimer = False Exit Sub End If If mblnAbbruch = True Then ' Abbruch wurde gedrückt Call Formularbeenden m_blnIsInTimer = False Exit Sub End If If m_TimerOn = False Then ' Timer wurde angehalten aber Timer Event stand noch aus m_blnIsInTimer = False Exit Sub End If For nIndex = 1 To g_App.Settings.EinbauplaetzeJeStrang ' Beim Scannen blinkt der Kreis Shape1.FillColor = Shape1.FillColor Xor 255 Set Einbauplatz = m_colEinbauplatz(nIndex) If mblnAbbruch = True Then Call Formularbeenden m_blnIsInTimer = False Exit Sub End If alteFarbe = txtSerienNr(nIndex).BackColor txtSerienNr(nIndex).BackColor = &HE0E0E0 ' am Scannen lblScanStat.caption = nIndex comport = Val(g_App.Settings.getUSComPort(nIndex)) If comport = 0 Then ' Einbauplatz-COMPort ist nicht definiert lblEinbau(nIndex).caption = "Err: no COM definded in ini" cmdSerNrAusw(nIndex).Enabled = False txtSerienNr(nIndex).Enabled = False Else ' Einbauplatz-COMPort ist definiert If m_blnDoStart = False Then DisableEventsForSensusIF (nIndex) 'Dim lngCountVersuche As Long 'lngCountVersuche = 0 lblEinbau(nIndex).caption = "..." DoEvents Set m_objSensusIFInterface = New SensusIF2.Interface m_objSensusIFInterface.CommPortNr = comport m_objSensusIFInterface.DebugWindowsIsVisible = True m_objSensusIFInterface.PortInit lngSuccess = 0 'If mblnAbbruch = True Then Exit Do 'If m_blnDoStart = True Then Exit Do 'lngCountVersuche = lngCountVersuche + 1 lngSuccess = m_objSensusIFInterface.GetFactoryID(strAntwort) If lngSuccess = 0 Then Debug.Print "WDH" End If 'Loop While lngSuccess = 0 And lngCountVersuche < g_CONSTTURBOVERSUCHE If lngSuccess = 1 Then If Left(lblEinbau(nIndex).caption, 3) = "Err" Then lblEinbau(nIndex).caption = "" End If ' Zähler antwortet txtSerienNr(nIndex).Enabled = True DoEvents ' FabNr lesen neueFabNr = strAntwort 'cmdSerNrAusw(nIndex).Enabled = True lblStatus(nIndex) = "FabNr: " & CStr(Val(neueFabNr)) If Val(neueFabNr) <> Val(Einbauplatz.getZusatz) Or txtSerienNr(nIndex) = "" Then ' es ist ein neuer Zähler Screen.MousePointer = vbHourglass 'Schloss prüfen 'Set objSensusIFInterface = New SensusIF2.Interface 'objSensusIFInterface.CommPortNr = ComPort 'objSensusIFInterface.DebugWindowsIsVisible = False 'objSensusIFInterface.PortInit If Not m_objSensusIFInterface.GetSealStatus(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 'Set objSensusIFInterface = Nothing ' Überprüfung auf Rechenwerksnennweite 'Einbauplatz.intErkannteQp = Round(USGetFlowSimu(Einbauplatz.getNr) * 3600, 0) 'Debug.Print "Rechenwerksnennweite (FlowSimu) : " & Einbauplatz.intErkannteQp Einbauplatz.setZusatz neueFabNr If Val(neueFabNr) > 0 Then ' FabNr ist vorhanden Set AuftragpositionSerienNr = New CAuftragPositionSerienNr If AuftragpositionSerienNr.loadFromFabNr(CLng(neueFabNr)) Then 'AuftragPositionSNr wurde gefunden, Zähler war schon mal hier txtSerienNr(nIndex).text = 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 EnableEventsForSensusIF (nIndex) Else EnableEventsForSensusIF (nIndex) ' Set objSensusIFInterface = New SensusIF2.Interface ' objSensusIFInterface.CommPortNr = ComPort ' objSensusIFInterface.DebugWindowsIsVisible = False ' objSensusIFInterface.PortInit ' kein Pong nach Ping ' Zähler antwortet nicht, d.h. ' Zaehler wurde ausgebaut oder nicht wieder gescannt EntferneZaehlerAusEinbauplatz (nIndex) lblEinbau(nIndex).caption = m_objSensusIFInterface.GetErrorMessage(lngSuccess) txtSerienNr(nIndex).Enabled = False cmdSerNrAusw(nIndex).Enabled = False lblStatus(nIndex) = "" ueberpruefe nIndex alteFarbe = vbWhite End If End If ' wenn nicht auf starten End If ' COM definiert txtSerienNr(nIndex).BackColor = alteFarbe DoEvents Next m_blnIsInTimer = False If m_blnDoStart Then Timer1.Enabled = False m_blnDoStart = False DoStartHauptprüfung End If Timer1.Enabled = m_TimerOn 'Timer (wenn gewünscht) wieder einschalten 'StopScan End Sub Private Sub EntferneZaehlerAusEinbauplatz(Index As Integer) ' Dim Einbauplatz As CEinbauplatz ' Set Einbauplatz = m_colEinbauplatz(Index) ' Einbauplatz.setPruefzaehler Nothing ' ' imgSchloss(Index).Picture = frmRes.ImgLeer.Picture m_colEinbauplatz(Index).setZusatz "" txtSerienNr(Index).text = "" imgSchloss(Index).Picture = frmRes.ImgLeer.Picture txtSerienNr(Index).BackColor = vbWhite lblEinbau(Index).caption = "" ' lblTimeout(Index).Caption = "" imgZaehler(Index).Enabled = False cmdSerNrAusw(Index).Enabled = False lblStatus(Index) = "" ' txtSerienNr(Index).Enabled = True ' ' On Error Resume Next ' txtSerienNr(Index).SetFocus ' On Error GoTo 0 ' ' txtSerienNr(Index).Enabled = False ' ' ueberpruefe Index End Sub Private Sub StartScan() Timer1.Interval = 1000 Timer1.Enabled = True Shape1.BackColor = &H80FF& m_TimerOn = True cmdStopScan.caption = "STOP SCAN" 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 Dim blnTimerOn As Boolean Dim lngSuccess As Long Dim blnFehler As Boolean 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 CStr(AuftragpositionSerienNr.getFabNr) <> geleseneFabNr Then Dim strTemp As String strTemp = "Möchten Sie diese Seriennr ('" & Pruefzaehler.getSerienNr & "') " & vbCrLf & "für diesen Turbo2e-Zähler" & vbCrLf & " (FabNr: '" & geleseneFabNr & "')" & vbCrLf & " zukünftig verwenden?" If MsgBox(strTemp, vbYesNo Or vbQuestion, "neue Seriennr verwenden?") = vbYes Then If geleseneFabNr <> "" Then If Not CheckAndCreateInSpeicherabbild(Einbauplatz.getNr, geleseneFabNr) Then MsgBox ("Speicherabbild wurde nicht gesichert.") Exit Sub End If Else MsgBox "Gelesene FabNr ist leer! Speicherabbild wurde nicht gesichert." End If comport = Val(g_App.Settings.getUSComPort(Index)) DisableEventsForSensusIF (Index) If m_objSensusIFInterface Is Nothing Then Set m_objSensusIFInterface = New SensusIF2.Interface m_objSensusIFInterface.CommPortNr = comport m_objSensusIFInterface.PortInit 'lngSuccess = objSensusIFInterface.SetFactoryID(Pruefzaehler.getSerienNr) blnFehler = True 'If lngSuccess = 1 Then 'lngSuccess = objSensusIFInterface.SetText(Pruefzaehler.getSerienNr) 'If lngSuccess = 1 Then lngSuccess = m_objSensusIFInterface.SetMeterID(Pruefzaehler.getSerienNr) If lngSuccess = 1 Then blnFehler = False Else MsgBox ("Fehler " & lngSuccess & " beim Schreiben der MeterID: " & m_objSensusIFInterface.GetErrorMessage(lngSuccess)) End If ' Else ' MsgBox ("Fehler " & lngSuccess & " beim Schreiben des Meter-Textes: " & objSensusIFInterface.GetErrorMessage(lngSuccess)) ' End If ' Else ' MsgBox ("Fehler " & lngSuccess & " beim Schreiben der FactoryID: " & objSensusIFInterface.GetErrorMessage(lngSuccess)) ' End If If blnFehler = False Then ' FactoryID, MeterID und Text wurden geschrieben! Einbauplatz.setZusatz Pruefzaehler.getSerienNr AuftragpositionSerienNr.setFabNr CLng(geleseneFabNr) AuftragpositionSerienNr.save If chkNurMesseinsaetze.value = vbUnchecked And chkVersuch.value = vbUnchecked Then ' kein Messeinsatz und kein Versuch 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 Turbo2 Zähler (FabNr=" & geleseneFabNr & ") liegen keine Ergebnisse der Druckprüfung vor!", "Druckpruefung" End If End If Else EntferneZaehlerAusEinbauplatz (Index) End If EnableEventsForSensusIF (Index) Else EntferneZaehlerAusEinbauplatz (Index) End If End If 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 Sub DisableEventsForSensusIF(Index As Integer) ' SensusIF Kommandos erlauben wähend des Wartens auf eine Antwort per DoEvents das Ausführen von anderen Events, wie ' z.B. das Vergeben von Seriennummern, das wiederum wieder SensusIF Kommandos benutzt. ' Deshalb müssen alle Events verhindert werden, solange auf eine SensusIF Antwort gewartet wird txtSerienNr(Index).Enabled = False cmdSerNrAusw(Index).Enabled = False Timer1.Enabled = False m_blnIsInSensusIF = True Debug.Print "DisableEvents" End Sub Private Sub EnableEventsForSensusIF(Index As Integer) txtSerienNr(Index).Enabled = True cmdSerNrAusw(Index).Enabled = True Timer1.Enabled = m_TimerOn m_blnIsInSensusIF = False Debug.Print "EnableEvents" End Sub Private Sub InitializeAllTurbo2e() Dim Einbauplatz As CEinbauplatz For Each Einbauplatz In m_colEinbauplatz If Not Einbauplatz.getPruefzaehler() Is Nothing Then InitializeTurbo2e Einbauplatz.getNr End If Next End Sub Private Function InitializeTurbo2e(ByVal EinbauplatzNr As Integer) As Long DisableEventsForSensusIF (EinbauplatzNr) Dim comport As Integer Dim blnError As Boolean Dim lngCountVersuche As Long Const MAXANZAHLVERSUCHE = 5 start: comport = Val(g_App.Settings.getUSComPort(EinbauplatzNr)) 'Dim objSensusIFInterface As SensusIF2.Interface Set m_objSensusIFInterface = New SensusIF2.Interface m_objSensusIFInterface.CommPortNr = comport m_objSensusIFInterface.PortInit m_objSensusIFInterface.DebugWindowsIsVisible = True DebugMsg "Initialisierung des Turbo2e am Einbauplatz " & EinbauplatzNr & " ..." lngCountVersuche = 0 Do InitializeTurbo2e = m_objSensusIFInterface.SetIndexUnit(SENSUSIF_EINHEIT.M3) If InitializeTurbo2e <> 1 Then lngCountVersuche = lngCountVersuche + 1 Sleep 100, True End If Loop While InitializeTurbo2e <> 1 And lngCountVersuche < MAXANZAHLVERSUCHE If InitializeTurbo2e <> 1 Then ErrorMsg "Fehler " & InitializeTurbo2e & " bei SetIndexUnit(m³): " & m_objSensusIFInterface.GetErrorMessage(InitializeTurbo2e) & vbCrLf & "(" & lngCountVersuche & " mal wiederholt)" blnError = True End If lngCountVersuche = 0 Do InitializeTurbo2e = m_objSensusIFInterface.SetDisplayMode(5) If InitializeTurbo2e <> 1 Then lngCountVersuche = lngCountVersuche + 1 Sleep 100, True End If Loop While InitializeTurbo2e <> 1 And lngCountVersuche < MAXANZAHLVERSUCHE If InitializeTurbo2e <> 1 Then ErrorMsg "Fehler " & InitializeTurbo2e & " bei SetDisplayMode(5): " & m_objSensusIFInterface.GetErrorMessage(InitializeTurbo2e) & vbCrLf & "(" & lngCountVersuche & " mal wiederholt)" blnError = True End If lngCountVersuche = 0 Do InitializeTurbo2e = m_objSensusIFInterface.SetAMRdigits(Chr(8) & Chr(0)) If InitializeTurbo2e <> 1 Then lngCountVersuche = lngCountVersuche + 1 Sleep 100, True End If Loop While InitializeTurbo2e <> 1 And lngCountVersuche < MAXANZAHLVERSUCHE If InitializeTurbo2e <> 1 Then ErrorMsg "Fehler " & InitializeTurbo2e & " bei SetAMRdigits(08 00) : " & m_objSensusIFInterface.GetErrorMessage(InitializeTurbo2e) & vbCrLf & "(" & lngCountVersuche & " mal wiederholt)" blnError = True End If ' InitializeTurbo2e = m_objSensusIFInterface.SetPulseOutput(7) ' If InitializeTurbo2e <> 1 Then ' MsgBox "Fehler " & InitializeTurbo2e & " bei SetPulseOutput: " & m_objSensusIFInterface.GetErrorMessage(InitializeTurbo2e) ' End If lngCountVersuche = 0 Do InitializeTurbo2e = m_objSensusIFInterface.SetFieldcorrection(0) If InitializeTurbo2e <> 1 Then lngCountVersuche = lngCountVersuche + 1 Sleep 100, True End If Loop While InitializeTurbo2e <> 1 And lngCountVersuche < MAXANZAHLVERSUCHE If InitializeTurbo2e <> 1 Then ErrorMsg "Fehler " & InitializeTurbo2e & " bei SetFieldcorrection(0): " & m_objSensusIFInterface.GetErrorMessage(InitializeTurbo2e) & vbCrLf & "(" & lngCountVersuche & " mal wiederholt)" blnError = True End If ' todo : abhängig von Nennweite, Auftrag etc ' InitializeTurbo2e = m_objSensusIFInterface.SetMetersizeVPRin(1, 9) ' If InitializeTurbo2e <> 1 Then ' MsgBox "Fehler " & InitializeTurbo2e & " bei SetMetersizeVPRin: " & m_objSensusIFInterface.GetErrorMessage(InitializeTurbo2e) ' End If If blnError = True Then If MsgBox("Initialisierung fehlgeschlagen. Soll die Initialisierung dieses Zählers wiederholt werden?", vbYesNo Or vbDefaultButton1) = vbYes Then GoTo start End If End If Set m_objSensusIFInterface = Nothing EnableEventsForSensusIF (EinbauplatzNr) End Function Private Sub DoStartHauptprüfung() Timer1.Enabled = False Screen.MousePointer = vbHourglass InitializeAllTurbo2e Screen.MousePointer = vbNormal Call Hauptpruefung Timer1.Enabled = True cmdOK.Enabled = True End Sub Private Sub cmdOk_Click() If m_blnDoStart = True Then MsgBox "es wird bereits gestartet" Exit Sub 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 ' Vorraussetzungen sind erfüllt Screen.MousePointer = vbHourglass cmdOK.Enabled = False m_blnDoStart = True If Timer1.Enabled = True Then Timer1.Enabled = False m_blnDoStart = False DoStartHauptprüfung End If End Sub Private Sub cmdStopScan_Click() If m_TimerOn = False Then StartScan Else StopScan End If 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