marekf/laatzen
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
6ca303dc90
laatzen/Pruef2000/source/frmTrefferquotenueberwachung.frm
Rowlander 70e2645059 Initial commit 3
2021-10-01 11:11:04 +02:00

315 lines
12 KiB
Plaintext
Raw Blame History

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.2#0"; "MSCOMCTL.OCX"
Begin VB.Form frmTrefferquotenueberwachung
Caption = "Pruef2000 Trefferquotenüberpruefung"
ClientHeight = 5985
ClientLeft = 60
ClientTop = 345
ClientWidth = 7050
LinkTopic = "Form2"
ScaleHeight = 5985
ScaleWidth = 7050
StartUpPosition = 3 'Windows-Standard
Begin VB.CommandButton cmdDrucken
Caption = "Drucken"
Height = 375
Left = 4380
TabIndex = 6
Top = 5070
Width = 855
End
Begin VB.TextBox txtAusgabe
Height = 2685
Left = 30
Locked = -1 'True
MultiLine = -1 'True
ScrollBars = 2 'Vertikal
TabIndex = 5
Top = 30
Width = 6975
End
Begin MSComctlLib.ProgressBar ProgressBar1
Height = 225
Left = 0
TabIndex = 3
Top = 5430
Width = 6975
_ExtentX = 12303
_ExtentY = 397
_Version = 393216
Appearance = 1
End
Begin VB.CommandButton cmdOK
Caption = "Schließen"
Height = 405
Left = 2700
TabIndex = 2
Top = 5070
Width = 1485
End
Begin VB.TextBox txtGrund
Height = 1305
Left = 90
TabIndex = 1
Top = 3630
Width = 6825
End
Begin MSComctlLib.StatusBar StatusBar1
Align = 2 'Unten ausrichten
Height = 315
Left = 0
TabIndex = 0
Top = 5670
Width = 7050
_ExtentX = 12435
_ExtentY = 556
Style = 1
_Version = 393216
BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628}
NumPanels = 1
BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628}
EndProperty
EndProperty
End
Begin VB.Label lblUrsache
Height = 795
Left = 120
TabIndex = 4
Top = 2760
Width = 6855
End
End
Attribute VB_Name = "frmTrefferquotenueberwachung"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private m_blnActivated As Boolean
Public m_lngAuftragNr As Long
Public m_intPositionNr As Integer
Public m_blnSendeMail As Boolean
Private Sub cmdDrucken_Click()
Dim strText As String
Me.MousePointer = vbHourglass
cmdDrucken.Enabled = False
strText = txtAusgabe.text & vbCrLf
If m_blnSendeMail = True Then
If Trim(txtGrund.text) <> "" Then
strText = strText & "Der Prüfer " & g_App.Mitarbeiter.getAnfangsbuchstabeVornameundName & " gab an der Prüfstation " & g_App.PruefstationNr & " folgende Vermutung über die Ursache an:" & vbCrLf & "---" & vbCrLf & txtGrund.text & vbCrLf & "---" & vbCrLf
Else
strText = strText & "Der Prüfer " & g_App.Mitarbeiter.getAnfangsbuchstabeVornameundName & " gab an der Prüfstation " & g_App.PruefstationNr & " keine Vermutung über die Ursache an." & vbCrLf
End If
End If
Printer.ScaleMode = vbMillimeters
Printer.Font.Size = 8
Printer.ScaleLeft = -15
Printer.ScaleTop = -20
Printer.Print ""
Printer.Print strText
Printer.EndDoc
Me.MousePointer = vbNormal
MsgBox "Das Trefferquoten-Ergebnis wurde gedruckt!"
cmdDrucken.Enabled = True
End Sub
Private Sub cmdOk_Click()
Dim strText As String
Me.MousePointer = vbHourglass
If m_blnSendeMail = True Then
strText = txtAusgabe.text & vbCrLf
If Trim(txtGrund.text) <> "" Then
strText = strText & "Der Prüfer " & g_App.Mitarbeiter.getAnfangsbuchstabeVornameundName & " gab an der Prüfstation " & g_App.PruefstationNr & " folgende Vermutung über die Ursache an:" & vbCrLf & "---" & vbCrLf & txtGrund.text & vbCrLf & "---" & vbCrLf
Else
strText = strText & "Der Prüfer " & g_App.Mitarbeiter.getAnfangsbuchstabeVornameundName & " gab an der Prüfstation " & g_App.PruefstationNr & " keine Vermutung über die Ursache an." & vbCrLf
End If
strText = strText & "Diese Mail wurde automatisch von Pruef2000.exe generiert."
If InStr(1, g_App.getDB.getConnection.ConnectionString, "Testreplikation") = 0 Then
SendMail "nobody@sensus.com", "Arno.Schramm@sensus.com;Juergen.Dreyer@sensus.com;Manfred.Born@sensus.com;sixSigma.Laatzen@sensus.com", "Trefferquote für Auftragposition " & m_lngAuftragNr & "/" & m_intPositionNr & " wurde unterschritten!", strText
StatusBar1.SimpleText = "Mail wurde versendet!"
Sleep 1000, True
Else
Me.MousePointer = vbNormal
MsgBox "Diese Mail würde versendet werden: " & vbCrLf & strText
End If
End If
Me.MousePointer = vbNormal
Unload Me
End Sub
Private Sub Form_Activate()
If m_blnActivated = False Then
UeberpruefeTrefferquote m_lngAuftragNr, m_intPositionNr, m_blnSendeMail
Me.MousePointer = vbNormal
Screen.MousePointer = vbNormal
End If
m_blnActivated = True
End Sub
Private Sub Form_Load()
cmdDrucken.Enabled = False
cmdOK.Enabled = False
txtGrund.Visible = False
End Sub
Private Sub Form_Resize()
txtAusgabe.Top = 0
txtAusgabe.Left = 0
txtAusgabe.Width = Me.ScaleWidth
Debug.Print "Me.Width=" & Me.Width & ", Me.Height=" & Me.Height
cmdOK.Left = (Me.ScaleWidth - cmdOK) / 2
cmdOK.Top = Me.ScaleHeight - StatusBar1.Height - cmdOK.Height * 1.5
cmdOK.Left = (Me.ScaleWidth - cmdOK.Width) / 2
cmdDrucken.Left = cmdOK.Left + 1.3 * cmdOK.Width
cmdDrucken.Top = cmdOK.Top
txtGrund.Top = cmdOK.Top - txtGrund.Height - cmdOK.Height / 2
txtGrund.Width = Me.ScaleWidth
txtGrund.Left = 0
ProgressBar1.Left = 0
ProgressBar1.Top = Me.ScaleHeight - StatusBar1.Height - ProgressBar1.Height
ProgressBar1.Width = Me.ScaleWidth
txtAusgabe.Height = txtGrund.Top - lblUrsache.Height * 1.1
lblUrsache.Top = txtAusgabe.Top + txtAusgabe.Height + lblUrsache.Height / 4
End Sub
Private Sub UeberpruefeTrefferquote(lngAuftragNr As Long, intPosNr As Integer, ByRef blnSendeMail As Boolean)
On Error GoTo Errorhandler
Dim dblTrefferquoteAuftrag As Double
Dim dblTrefferquoteZaehler As Double
Dim strText As String
Dim AnzahlZaehler As Long
Dim AnzahlZaehlerAuftragPosition As Long
Dim AuftragPosition As CAuftragPosition
Dim lngAnzahlWiederholungenAuftrag As Long
Dim objIdentNr As CIdentNr
Set AuftragPosition = New CAuftragPosition
AuftragPosition.load lngAuftragNr, intPosNr
Set objIdentNr = AuftragPosition.getIdentNrObj
Me.MousePointer = vbHourglass
lblUrsache.Visible = False
strText = ""
StatusBar1.SimpleText = "überprüfe Trefferquote der Auftragsposition..."
ProgressBar1.Visible = True
dblTrefferquoteAuftrag = Trefferquote(lngAuftragNr, intPosNr, , , , , , , ProgressBar1, , AnzahlZaehlerAuftragPosition, lngAnzahlWiederholungenAuftrag)
strText = strText & "Auftragposition " & lngAuftragNr & "/" & intPosNr & vbCrLf
strText = strText & " Auftragsmenge: " & AuftragPosition.getMenge & vbCrLf
strText = strText & " Trefferquote=" & dblTrefferquoteAuftrag & " %" & vbCrLf
strText = strText & " Wiederholungen=" & lngAnzahlWiederholungenAuftrag & vbCrLf
strText = strText & vbCrLf
txtAusgabe.text = strText
DoEvents
StatusBar1.SimpleText = "überprüfe Trefferquote des Zählertyps..."
dblTrefferquoteZaehler = Trefferquote(, , Now - 183, Now - 1, objIdentNr.getTyp, objIdentNr.getNennweite, objIdentNr.GetTemperatur, AuftragPosition.getMetrolog, ProgressBar1, , AnzahlZaehler)
strText = strText & "Zählertyp " & objIdentNr.getTyp & " " & objIdentNr.getNennweite & " " & objIdentNr.GetTemperatur & "°C, Metrolog=" & AuftragPosition.getMetrolog & vbCrLf
strText = strText & " Trefferquote=" & dblTrefferquoteZaehler & " %" & vbCrLf
strText = strText & " (Zeitraum: 1/2 Jahr, " & AnzahlZaehler & " Zähler)" & vbCrLf
strText = strText & vbCrLf
txtAusgabe.text = strText
DoEvents
StatusBar1.SimpleText = ""
ProgressBar1.Visible = False
Me.MousePointer = vbNormal
cmdOK.Enabled = True
cmdOK.Visible = True
cmdDrucken.Enabled = True
If AuftragPosition.getMenge >= 20 And dblTrefferquoteAuftrag > 0 And AnzahlZaehlerAuftragPosition > 20 And AnzahlZaehler >= 100 Then
If dblTrefferquoteZaehler > 0 Then
If dblTrefferquoteAuftrag < dblTrefferquoteZaehler - 10 Then
strText = strText & "Die Trefferquote der Auftragposition ist mind. 10% kleiner als die Halbjahresdurchschnitts-Trefferquote des Zählertypes und der Metrolog!" & vbCrLf
strText = strText & vbCrLf
txtAusgabe.BackColor = RGB(255, 200, 200)
LogIntoDB "Trefferquote für Auftragposition " & lngAuftragNr & "/" & intPosNr & " wurde unterschritten!", "Trefferquote"
txtAusgabe.text = strText
DoEvents
If m_blnSendeMail = True Then
txtGrund.Visible = True
lblUrsache.Visible = True
lblUrsache.caption = "Diese Info wird an die QS übermittelt." & vbCrLf & vbCrLf
lblUrsache.caption = lblUrsache.caption & "Hier haben Sie die Möglichkeit Vermutungen über die Ursache einzugeben:"
End If
Exit Sub
Else
strText = strText & "Die Trefferquote " & dblTrefferquoteAuftrag & "% (Auftragsposition) ist OK."
txtAusgabe.BackColor = RGB(200, 255, 200)
blnSendeMail = False
End If
Else
blnSendeMail = False
txtAusgabe.text = txtAusgabe.text & "Die Trefferquote des Zählertyps ist nicht ermittelbar (=0) für " & objIdentNr.getTyp & " " & objIdentNr.getNennweite & " " & objIdentNr.GetTemperatur & "°C"
LogIntoDB "Trefferquote des Zählers ist nicht ermittelbar: " & objIdentNr.getTyp & " " & objIdentNr.getNennweite & " " & objIdentNr.GetTemperatur & "°C", "Trefferquote"
Exit Sub
End If
Else
blnSendeMail = False
If dblTrefferquoteAuftrag <= 0 Then
txtAusgabe.text = txtAusgabe.text & "Die Trefferquote der Auftragposition ist nicht ermittelbar " & lngAuftragNr & "/" & intPosNr & "."
Sleep 5000, True
Unload Me
Exit Sub
End If
If AnzahlZaehler < 100 Then
txtAusgabe.text = txtAusgabe.text & "Zuwenig Zähler (<100) im letzten halben Jahr für einen Trefferquotenvergleich!"
Sleep 5000, True
Unload Me
Exit Sub
End If
If AuftragPosition.getMenge < 20 Then
txtAusgabe.text = txtAusgabe.text & "Die Auftragsmenge ist zu klein (< 20) für einen Trefferquotenvergleich!"
Sleep 5000, True
Unload Me
Exit Sub
End If
If AnzahlZaehlerAuftragPosition < 20 Then
txtAusgabe.text = "Die geprüfte Menge ist zu klein (< 20) für einen Trefferquotenvergleich!"
Sleep 5000, True
Unload Me
Exit Sub
End If
End If
txtAusgabe.text = strText
cmdOK.Default = True
' Dim i As Integer
' For i = 60 To 1 Step -1
' cmdOK.Caption = " Schließen in " & i & " s"
' Sleep 1000, True
' Next
' Unload Me
Exit Sub
Errorhandler:
LogIntoDB "Fehler " & Err.Number & " in UeberpruefeTrefferquote: " & Err.Description, "Fehler"
blnSendeMail = False
End Sub
Reference in New Issue View Git Blame Copy Permalink