Exported VBA

wgmaster/vba/Form_FAbschlaege.frm

@@ -0,0 +1,38 @@
+Private Sub LGNR_Exit(Cancel As Integer)
+
+End Sub
+Private Sub Befehl46_Click()
+On Error GoTo Err_Befehl46_Click
+
+    Dim stDocName As String
+
+    stDocName = "BAbschlaege"
+    DoCmd.OpenReport stDocName, acViewPreview
+
+Exit_Befehl46_Click:
+    Exit Sub
+
+Err_Befehl46_Click:
+    MsgBox Err.Description
+    Resume Exit_Befehl46_Click
+    
+End Sub
+
+
+Private Sub TAZAS_Exit(Cancel As Integer)
+
+If Not IsNull(TAZAS) And Not IsNull(TAZASProzent) Then
+ MsgBox "Es kann pro Zu/Abschlag entweder ein absoluter Wert oder ein Prozentwert angegeben werden, aber nicht beides !", vbCritical
+ TAZAS = ""
+End If
+
+End Sub
+
+Private Sub TAZASProzent_Exit(Cancel As Integer)
+
+If Not IsNull(TAZAS) And Not IsNull(TAZASProzent) Then
+ MsgBox "Es kann pro Zu/Abschlag entweder ein absoluter Wert oder ein Prozentwert angegeben werden, aber nicht beides !", vbCritical
+ TAZASProzent = ""
+End If
+
+End Sub

wgmaster/vba/Form_FAllgemein.frm

@@ -0,0 +1,58 @@
+Option Compare Database
+Option Explicit
+
+
+
+Private Sub Form_Close()
+
+'If Not IsNull(GetParameter("LIEFERRECHT/GA1")) Then TLieferrecht1 = CDbl(GetParameter("LIEFERRECHT/GA1"))
+'If Not IsNull(GetParameter("LIEFERRECHT/GA2")) Then TLieferrecht2 = CDbl(GetParameter("LIEFERRECHT/GA2"))
+'If Not IsNull(GetParameter("LIEFERPFLICHT/GA1")) Then TLieferpflicht1 = CDbl(GetParameter("LIEFERPFLICHT/GA1"))
+'If Not IsNull(GetParameter("LIEFERPFLICHT/GA2")) Then TLieferpflicht2 = CDbl(GetParameter("LIEFERPFLICHT/GA2"))
+
+If Not IsNull(TEurofaktor) Then SetParameter "EUROFAKTOR", TEurofaktor
+If Not IsNull(TMwSt1) Then SetParameter "MWST1", TMwSt1
+If Not IsNull(TMwSt2) Then SetParameter "MWST2", TMwSt2
+If Not IsNull(TMwSt3) Then SetParameter "MWST3", TMwSt3
+If Not IsNull(TGB) Then SetParameter "GB", TGB
+If Not IsNull(TRebelabzug) Then SetParameter "REBELABZUG", TRebelabzug
+
+If Not IsNull(TLieferrecht1) Then SetParameter "LIEFERRECHT/GA1", TLieferrecht1
+If Not IsNull(TLieferrecht2) Then SetParameter "LIEFERRECHT/GA2", TLieferrecht2
+If Not IsNull(TLieferpflicht1) Then SetParameter "LIEFERPFLICHT/GA1", TLieferpflicht1
+If Not IsNull(TLieferpflicht2) Then SetParameter "LIEFERPFLICHT/GA2", TLieferpflicht2
+
+If Not IsNull(TMAXERTRAG) Then SetParameter "MAXERTRAG", TMAXERTRAG
+If Not IsNull(TAufschlagVollieferant) Then SetParameter "AUFSCHLAGVOLLLIEFERANT", TAufschlagVollieferant
+
+
+End Sub
+
+Private Sub Form_Open(Cancel As Integer)
+
+
+If Not IsNull(GetParameter("EUROFAKTOR")) Then TEurofaktor = CDbl(GetParameter("EUROFAKTOR"))
+If Not IsNull(GetParameter("MWST1")) Then TMwSt1 = CDbl(GetParameter("MWST1"))
+If Not IsNull(GetParameter("MWST2")) Then TMwSt2 = CDbl(GetParameter("MWST2"))
+If Not IsNull(GetParameter("MWST3")) Then TMwSt3 = CDbl(GetParameter("MWST3"))
+
+If Not IsNull(GetParameter("GB")) Then TGB = CDbl(GetParameter("GB"))
+If Not IsNull(GetParameter("REBELABZUG")) Then TRebelabzug = CDbl(GetParameter("REBELABZUG"))
+
+If Not IsNull(GetParameter("LIEFERRECHT/GA1")) Then TLieferrecht1 = CDbl(GetParameter("LIEFERRECHT/GA1"))
+If Not IsNull(GetParameter("LIEFERRECHT/GA2")) Then TLieferrecht2 = CDbl(GetParameter("LIEFERRECHT/GA2"))
+If Not IsNull(GetParameter("LIEFERPFLICHT/GA1")) Then TLieferpflicht1 = CDbl(GetParameter("LIEFERPFLICHT/GA1"))
+If Not IsNull(GetParameter("LIEFERPFLICHT/GA2")) Then TLieferpflicht2 = CDbl(GetParameter("LIEFERPFLICHT/GA2"))
+
+If Not IsNull(GetParameter("MAXERTRAG")) Then TMAXERTRAG = CDbl(GetParameter("MAXERTRAG"))
+
+If Not IsNull(GetParameter("AUFSCHLAGVOLLLIEFERANT")) Then TAufschlagVollieferant = CDbl(GetParameter("AUFSCHLAGVOLLLIEFERANT"))
+
+
+End Sub
+
+
+
+
+
+

wgmaster/vba/Form_FAuszahlungParameter.frm

@@ -0,0 +1,166 @@
+Option Compare Database
+Option Explicit
+
+
+
+Private Sub BOk_Click()
+
+Dim a(0 To 5) As Double
+Dim g(0 To 5) As Double
+Dim o(0 To 5) As Double
+Dim i As Integer
+
+Dim aznr1 As Long
+Dim QSNR1 As Long
+Dim SNR1 As String
+Dim SANR1 As String
+Dim start1 As Long
+Dim gebunden1 As Integer
+Dim maxreihe As Integer
+Dim Oechsle1 As Long
+
+Dim db1 As Database
+Dim rs1 As Recordset
+
+aznr1 = Forms!FAuszahlung!TAZNR
+SNR1 = Forms!FAuszahlung!TSNR
+gebunden1 = Forms!FAuszahlung!TGebunden
+If IsNull(Forms!FAuszahlung!TSANR) Then
+ SANR1 = "NULL"
+Else
+ SANR1 = "'" + Forms!FAuszahlung!TSANR + "'"
+End If
+
+maxreihe = 0
+
+If Not IsNull(TO1) Then
+ o(1) = TO1
+ a(1) = TA1
+ g(1) = TG1
+ maxreihe = 1
+End If
+
+If Not IsNull(TO2) Then
+ o(2) = TO2
+ a(2) = TA2
+ g(2) = TG2
+ maxreihe = 2
+End If
+
+If Not IsNull(TO3) Then
+ o(3) = TO3
+ a(3) = TA3
+ g(3) = TG3
+ maxreihe = 3
+End If
+
+If Not IsNull(TO4) Then
+ o(4) = TO4
+ a(4) = TA4
+ g(4) = TG4
+ maxreihe = 4
+End If
+
+If Not IsNull(TO5) Then
+ o(5) = TO5
+ a(5) = TA5
+ g(5) = TG5
+ maxreihe = 5
+End If
+
+If maxreihe = 0 Then
+ MsgBox "Sie müssen zumindest die Parameter für Reihe 1 eingeben!", vbCritical
+ Exit Sub
+ 
+End If
+
+Set db1 = CurrentDb
+
+Set rs1 = db1.OpenRecordset("SELECT * FROM TAuszahlungSorten WHERE AZNR=" + Format(aznr1) + " AND SNR='" + Format(SNR1) + "' AND Gebunden=" + Format(gebunden1) + " AND SANR=" + SANR1)
+
+While Not rs1.EOF
+ 
+ rs1.Edit
+ 
+ Oechsle1 = rs1!Oechsle
+ 
+ i = maxreihe
+ While i > 0 And Oechsle1 < o(i)
+  i = i - 1
+ Wend
+ 
+ If i > 0 Then
+  rs1!Betrag = g(i) + (Oechsle1 - o(i)) * a(i)
+ Else
+  rs1!Betrag = 0
+ End If
+ 
+ rs1.Update
+ rs1.MoveNext
+ 
+Wend
+rs1.Close
+
+'Parameter sichern
+If Not IsNull(TO1) Then SetParameter "AuszahlungParameterReihe1OechsleStart", TO1
+If Not IsNull(TO2) Then SetParameter "AuszahlungParameterReihe2OechsleStart", TO2
+If Not IsNull(TO3) Then SetParameter "AuszahlungParameterReihe3OechsleStart", TO3
+If Not IsNull(TO4) Then SetParameter "AuszahlungParameterReihe4OechsleStart", TO4
+If Not IsNull(TO5) Then SetParameter "AuszahlungParameterReihe5OechsleStart", TO5
+
+If Not IsNull(TG1) Then SetParameter "AuszahlungParameterReihe1Grundwert", TG1
+If Not IsNull(TG2) Then SetParameter "AuszahlungParameterReihe2Grundwert", TG2
+If Not IsNull(TG3) Then SetParameter "AuszahlungParameterReihe3Grundwert", TG3
+If Not IsNull(TG4) Then SetParameter "AuszahlungParameterReihe4Grundwert", TG4
+If Not IsNull(TG5) Then SetParameter "AuszahlungParameterReihe5Grundwert", TG5
+
+If Not IsNull(TA1) Then SetParameter "AuszahlungParameterReihe1Anstieg", TA1
+If Not IsNull(TA2) Then SetParameter "AuszahlungParameterReihe2Anstieg", TA2
+If Not IsNull(TA3) Then SetParameter "AuszahlungParameterReihe3Anstieg", TA3
+If Not IsNull(TA4) Then SetParameter "AuszahlungParameterReihe4Anstieg", TA4
+If Not IsNull(TA5) Then SetParameter "AuszahlungParameterReihe5Anstieg", TA5
+
+DoCmd.Close
+Forms!FAuszahlung!FUnter1.Requery
+
+End Sub
+
+Private Sub Form_Open(Cancel As Integer)
+
+Dim v
+
+v = GetParameter("AuszahlungParameterReihe1OechsleStart")
+If Not IsNull(v) Then TO1 = v
+v = GetParameter("AuszahlungParameterReihe2OechsleStart")
+If Not IsNull(v) Then TO2 = v
+v = GetParameter("AuszahlungParameterReihe3OechsleStart")
+If Not IsNull(v) Then TO3 = v
+v = GetParameter("AuszahlungParameterReihe4OechsleStart")
+If Not IsNull(v) Then TO4 = v
+v = GetParameter("AuszahlungParameterReihe5OechsleStart")
+If Not IsNull(v) Then TO5 = v
+
+v = GetParameter("AuszahlungParameterReihe1Grundwert")
+If Not IsNull(v) Then TG1 = v
+v = GetParameter("AuszahlungParameterReihe2Grundwert")
+If Not IsNull(v) Then TG2 = v
+v = GetParameter("AuszahlungParameterReihe3Grundwert")
+If Not IsNull(v) Then TG3 = v
+v = GetParameter("AuszahlungParameterReihe4Grundwert")
+If Not IsNull(v) Then TG4 = v
+v = GetParameter("AuszahlungParameterReihe5Grundwert")
+If Not IsNull(v) Then TG5 = v
+
+v = GetParameter("AuszahlungParameterReihe1Anstieg")
+If Not IsNull(v) Then TA1 = v
+v = GetParameter("AuszahlungParameterReihe2Anstieg")
+If Not IsNull(v) Then TA2 = v
+v = GetParameter("AuszahlungParameterReihe3Anstieg")
+If Not IsNull(v) Then TA3 = v
+v = GetParameter("AuszahlungParameterReihe4Anstieg")
+If Not IsNull(v) Then TA4 = v
+v = GetParameter("AuszahlungParameterReihe5Anstieg")
+If Not IsNull(v) Then TA5 = v
+
+
+End Sub

wgmaster/vba/Form_FAuszahlungSorten.frm

@@ -0,0 +1,19 @@
+Private Sub LGNR_Exit(Cancel As Integer)
+
+End Sub
+Private Sub Befehl46_Click()
+On Error GoTo Err_Befehl46_Click
+
+    Dim stDocName As String
+
+    stDocName = "BBewirtschaftungsarten"
+    DoCmd.OpenReport stDocName, acViewPreview
+
+Exit_Befehl46_Click:
+    Exit Sub
+
+Err_Befehl46_Click:
+    MsgBox Err.Description
+    Resume Exit_Befehl46_Click
+    
+End Sub

wgmaster/vba/Form_FAuszahlungSortenAuswahl.frm

@@ -0,0 +1,108 @@
+Option Compare Database
+Option Explicit
+
+
+
+
+
+Private Sub Befehl51_Click()
+
+DoCmd.Close
+
+End Sub
+
+Private Sub BOk_Click()
+
+Dim aznr1 As Long ' the actual AZNR
+Dim SNR1 As String  ' actual snr
+Dim SANR1 As String
+Dim SNR2 As String
+Dim SANR2 As String
+
+Dim db1 As Database
+Dim rs1 As Recordset
+Dim rs2 As Recordset
+Dim i As Long
+Dim gebunden1 As Integer
+Dim gebunden2 As Integer
+Dim varElement As Variant
+
+
+If MsgBox("Wollen Sie die eingegebene Sortentabelle auf die ausgewählten Sorten kopieren ?", vbYesNo) = vbYes Then
+
+DoCmd.Hourglass True
+ aznr1 = Forms!FAuszahlung!TAZNR
+ SNR1 = Forms!FAuszahlung!TSNR
+ gebunden1 = Forms!FAuszahlung!TGebunden
+ If IsNull(Forms!FAuszahlung!TSANR) Then
+  SANR1 = ""
+ Else
+  SANR1 = Forms!FAuszahlung!TSANR
+ End If
+
+
+Set db1 = CurrentDb
+
+
+'For Each varElement In LSorten.ItemsSelected
+For i = 0 To LSorten.ListCount - 1
+
+    If LSorten.Selected(i) Then
+    
+     LSorten.BoundColumn = 1
+     SNR2 = LSorten.ItemData(i)
+     LSorten.BoundColumn = 5
+     If IsNull(LSorten.ItemData(i)) Then
+      SANR2 = ""
+     Else
+      SANR2 = LSorten.ItemData(i)
+     End If
+     LSorten.BoundColumn = 4
+     If LSorten.ItemData(i) = "gebunden" Then
+      gebunden2 = True
+     Else
+      gebunden2 = False
+     End If
+     
+     'MsgBox (SNR2)
+     
+     If SANR1 = "" Then
+      Set rs1 = db1.OpenRecordset("SELECT * FROM TAuszahlungSorten WHERE AZNR=" + Format(Forms!FAuszahlung!TAZNR) + " AND SNR='" + SNR1 + "' AND Gebunden=" + Format(gebunden1) + " AND SANR IS NULL ORDER BY Oechsle")
+     Else
+      Set rs1 = db1.OpenRecordset("SELECT * FROM TAuszahlungSorten WHERE AZNR=" + Format(Forms!FAuszahlung!TAZNR) + " AND SNR='" + SNR1 + "' AND Gebunden=" + Format(gebunden1) + " AND SANR='" + SANR1 + "' ORDER BY Oechsle")
+     End If
+     If SANR2 = "" Then
+      Set rs2 = db1.OpenRecordset("SELECT * FROM TAuszahlungSorten WHERE AZNR=" + Format(Forms!FAuszahlung!TAZNR) + " AND SNR='" + SNR2 + "' AND Gebunden=" + Format(gebunden2) + " AND SANR IS NULL ORDER BY Oechsle")
+     Else
+      Set rs2 = db1.OpenRecordset("SELECT * FROM TAuszahlungSorten WHERE AZNR=" + Format(Forms!FAuszahlung!TAZNR) + " AND SNR='" + SNR2 + "' AND Gebunden=" + Format(gebunden2) + " AND SANR='" + SANR2 + "' ORDER BY Oechsle")
+     End If
+     
+     While Not rs1.EOF
+        
+      
+      rs2.Edit
+      rs2!Betrag = rs1!Betrag
+      rs2.Update
+    
+      
+      rs2.MoveNext
+      rs1.MoveNext
+     
+     Wend
+     
+     rs1.Close
+     rs2.Close
+     
+    End If
+
+'Next varElement
+Next i
+
+DoCmd.Hourglass False
+
+End If
+
+DoCmd.Close
+Forms!FAuszahlung!FUnter1.Requery
+
+End Sub

wgmaster/vba/Form_FAuszahlungSortenQualitätsstufe.frm

@@ -0,0 +1,19 @@
+Private Sub LGNR_Exit(Cancel As Integer)
+
+End Sub
+Private Sub Befehl46_Click()
+On Error GoTo Err_Befehl46_Click
+
+    Dim stDocName As String
+
+    stDocName = "BBewirtschaftungsarten"
+    DoCmd.OpenReport stDocName, acViewPreview
+
+Exit_Befehl46_Click:
+    Exit Sub
+
+Err_Befehl46_Click:
+    MsgBox Err.Description
+    Resume Exit_Befehl46_Click
+    
+End Sub

wgmaster/vba/Form_FBanken.frm

@@ -0,0 +1,19 @@
+Private Sub LGNR_Exit(Cancel As Integer)
+
+End Sub
+Private Sub Befehl46_Click()
+On Error GoTo Err_Befehl46_Click
+
+    Dim stDocName As String
+
+    stDocName = "BBanken"
+    DoCmd.OpenReport stDocName, acViewPreview
+
+Exit_Befehl46_Click:
+    Exit Sub
+
+Err_Befehl46_Click:
+    MsgBox Err.Description
+    Resume Exit_Befehl46_Click
+    
+End Sub

wgmaster/vba/Form_FBehaelter.frm

@@ -0,0 +1,5 @@
+Private Sub BBehälterlisteDrucken_Click()
+
+DoCmd.OpenReport "BBehaelter", acViewPreview
+
+End Sub

wgmaster/vba/Form_FBewirtschaftungsarten.frm

@@ -0,0 +1,19 @@
+Private Sub LGNR_Exit(Cancel As Integer)
+
+End Sub
+Private Sub Befehl46_Click()
+On Error GoTo Err_Befehl46_Click
+
+    Dim stDocName As String
+
+    stDocName = "BBewirtschaftungsarten"
+    DoCmd.OpenReport stDocName, acViewPreview
+
+Exit_Befehl46_Click:
+    Exit Sub
+
+Err_Befehl46_Click:
+    MsgBox Err.Description
+    Resume Exit_Befehl46_Click
+    
+End Sub

wgmaster/vba/Form_FChargeUmfuellen.frm

@@ -0,0 +1,179 @@
+
+Dim lastCNR
+
+
+
+Private Sub BJahrWeiter_Click()
+
+If Not IsNull(TLesejahr) Then
+ TLesejahr = TLesejahr + 1
+ RefreshAll
+End If
+
+End Sub
+
+Private Sub BJahrZurueck_Click()
+
+If Not IsNull(TLesejahr) Then
+ TLesejahr = TLesejahr - 1
+ RefreshAll
+End If
+
+End Sub
+
+Private Sub BUmfuellen_Click()
+
+Dim CNR1 As Long
+
+Select Case XUmfuellenOption
+
+Case 1: 'vorhandene
+  
+  ChargeUmfuellen Forms("MChargenAuswahl")!LChargen, LChargen, TMenge, OMengeZuruecksetzen, OOechsleZuruecksetzen, OStatusEntleert
+
+Case 2: 'neue
+ CNR1 = ChargeClonen(Forms("MChargenAuswahl")!LChargen, TBNR, 0, 0)
+ ChargeUmfuellen Forms("MChargenAuswahl")!LChargen, CNR1, TMenge, OMengeZuruecksetzen, OOechsleZuruecksetzen, OStatusEntleert
+
+End Select
+
+DoCmd.Close
+
+End Sub
+
+Private Sub Form_Activate()
+
+RefreshAll
+
+End Sub
+
+Private Sub Form_Load()
+ 
+OMengeZuruecksetzen = True
+OOechsleZuruecksetzen = True
+OStatusEntleert = True
+
+If Month(Date) < 9 Then
+ TLesejahr = year(Date) - 1
+Else
+ TLesejahr = year(Date)
+End If
+
+lastCNR = -1
+
+TMenge = DFirst("Menge", "TChargen", "CNR=Forms!MChargenAuswahl!LChargen")
+
+
+
+XUmfuellenOption = 1
+
+RefreshAll
+
+
+
+End Sub
+
+Private Sub LChargen_DblClick(Cancel As Integer)
+
+lastCNR = LChargen
+
+ChargeUmfuellen Forms("MChargenAuswahl")!LChargen, LChargen, TMenge, OMengeZuruecksetzen, OOechsleZuruecksetzen, OStatusEntleert
+DoCmd.Close
+
+End Sub
+
+Private Sub TLesejahr_Exit(Cancel As Integer)
+
+RefreshAll
+
+End Sub
+
+Function GetFilter() As String
+
+Dim filter1
+
+filter1 = "Jahrgang=" + Format(TLesejahr)
+
+filter1 = filter1 + " AND TChargen.CSNR=2"
+filter1 = filter1 + " AND TChargen.CNR<>" + Format(Forms("MChargenAuswahl")!LChargen)
+
+If Not IsNull(TZNR) Then
+  filter1 = filter1 + " AND TChargen.ZNR=" + TZNR
+End If
+
+GetFilter = filter1
+
+End Function
+
+Function GetOrder() As String
+
+ GetOrder = " ORDER BY BefuellungsBeginn"
+
+End Function
+
+
+Sub RefreshAll()
+
+Dim filter1
+Dim query1
+
+'query1 = "SELECT TLieferungen.CNR, TLieferungen.Lieferscheinnummer AS Lieferscheinnr, TLieferungen.Datum, Format(TLieferungen.Uhrzeit,'HH:MM') as Zeit, TMitglieder.MGNR, [Nachname]+' '+IIf(IsNull([Vorname]),'',[Vorname]) AS Mitglied, TSorten.Bezeichnung AS Sorte, TLieferungen.Gewicht, TLieferungen.Oechsle, IIf(Storniert=True,'STORNIERT',Left(TLieferungen.Anmerkung,20)) AS Info FROM TSorten INNER JOIN (TMitglieder INNER JOIN TLieferungen ON TMitglieder.MGNR = TLieferungen.MGNR) ON TSorten.SNR = TLieferungen.SNR"
+query1 = "SELECT TChargen.CNR, TChargen.Chargennummer as ChNr, TChargen.Befuellungsbeginn as BefStart, TChargen.Befuellungsende as BefEnde, TChargen.BehaelterEntleertAm as Entleerg, TChargenStatus.ChargenStatus as Status, TChargen.SNR, TChargen.SANR, TQualitaetsstufen.Bezeichnung as Qualitaet, TChargen.Menge,TBehaelter.Kurzbezeichnung as Behaelter, TZweigstellen.Name as Zweigstelle FROM ((TZweigstellen RIGHT JOIN (TChargen LEFT JOIN TChargenStatus ON TChargen.CSNR = TChargenStatus.CSNR) ON TZweigstellen.ZNR = TChargen.ZNR) LEFT JOIN TBehaelter ON TChargen.BNR = TBehaelter.BNR) LEFT JOIN TQualitaetsstufen ON TChargen.QSNRVon = TQualitaetsstufen.QSNR"
+filter1 = GetFilter
+query1 = query1 + " WHERE " + filter1 + GetOrder
+'MsgBox (query1)
+LChargen.RowSource = query1
+LChargen.Requery
+
+'LChargen.SetFocus
+
+If lastCNR = -1 And LChargen.ListCount > 0 Then
+'MsgBox (LChargen.ItemData(1))
+ LChargen = LChargen.ItemData(1)
+End If
+
+If lastCNR >= 0 Then
+ LChargen = lastCNR
+End If
+
+
+End Sub
+
+Private Sub TSortierung_Change()
+
+RefreshAll
+
+End Sub
+
+Private Sub TZNR_Change()
+
+RefreshAll
+
+End Sub
+
+Private Sub XUmfuellenOption_Click()
+
+Select Case XUmfuellenOption
+
+Case 1: 'vorhandene
+LChargen.Visible = True
+TLesejahr.Visible = True
+TZNR.Visible = True
+BJahrZurueck.Visible = True
+BJahrWeiter.Visible = True
+TBNR.Visible = False
+LBehaelter.Visible = False
+
+Case 2: 'neue
+TBNR.Visible = True
+LChargen.Visible = False
+TLesejahr.Visible = False
+TZNR.Visible = False
+BJahrZurueck.Visible = False
+BJahrWeiter.Visible = False
+LBehaelter.Visible = True
+
+
+End Select
+
+End Sub

wgmaster/vba/Form_FChargen.frm

@@ -0,0 +1,70 @@
+Private Sub BBefüllungBeenden_Click()
+
+ChargeBefuellungBeenden (TCNR)
+
+End Sub
+
+Private Sub BBefüllungStarten_Click()
+
+ChargeBefuellungStarten (TCNR)
+
+End Sub
+
+Private Sub BChargenstammblatt_Click()
+
+DoCmd.OpenReport "BChargenStammblatt", acViewPreview, , "CNR=" + Format(TCNR)
+
+End Sub
+
+Private Sub BUmfuellen_Click()
+
+DoCmd.OpenForm "FChargeUmfuellen"
+
+End Sub
+
+Private Sub Form_Current()
+
+LLieferungen.Requery
+LChargenVorgaenger.Requery
+LChargenNachfolger.Requery
+
+End Sub
+
+Private Sub LChargenNachfolger_DblClick(Cancel As Integer)
+
+filter = "CNR=" + Format(LChargenNachfolger)
+FilterOn = True
+
+End Sub
+
+Private Sub LChargenVorgaenger_DblClick(Cancel As Integer)
+
+filter = "CNR=" + Format(LChargenVorgaenger)
+FilterOn = True
+
+
+End Sub
+
+Private Sub TBNR_Exit(Cancel As Integer)
+
+RefreshChargennummer
+
+End Sub
+
+Sub RefreshChargennummer()
+
+Dim Maxcounter1 As Long
+'MsgBox (TChargennummer)
+If IsNull(TChargennummer) And TBNR > 0 Then
+ DoCmd.DoMenuItem acFormBar, acRecordsMenu, acSaveRecord, , acMenuVer70
+ TChargennummer = GeneriereChargennummer(TCNR, Maxcounter1)
+ TChargennummerZaehler = Maxcounter1
+End If
+
+End Sub
+
+Private Sub TChargennummer_Exit(Cancel As Integer)
+
+RefreshChargennummer
+
+End Sub

wgmaster/vba/Form_FChargenBehandlungen.frm

@@ -0,0 +1,5 @@
+Private Sub BBehälterlisteDrucken_Click()
+
+DoCmd.OpenReport "BBehaelter", acViewPreview
+
+End Sub

wgmaster/vba/Form_FFlaechenbindungen.frm

@@ -0,0 +1,24 @@
+Private Sub BNeuerNied_Click()
+
+If IsNull(LGNR) Then
+  MsgBox "Bitte zuerst Gemeinde auswählen !", vbCritical
+Else
+  DoCmd.OpenForm ("FRiedeMitglied")
+End If
+
+
+End Sub
+
+Private Sub LRiede_GotFocus()
+query1 = "SELECT RNR, BEZEICHNUNG FROM TRiede WHERE GNR=" + Format(LGNR) + " order by BEZEICHNUNG "
+LRiede.RowSource = query1
+LRiede.Requery
+
+End Sub
+
+Private Sub LRiede_LostFocus()
+query1 = "SELECT RNR, BEZEICHNUNG FROM TRiede order by BEZEICHNUNG;"
+LRiede.RowSource = query1
+LRiede.Requery
+
+End Sub

wgmaster/vba/Form_FGebiete.frm

@@ -0,0 +1,27 @@
+Option Compare Database
+Option Explicit
+
+Private Sub Form_Close()
+
+RefreshMain
+
+End Sub
+
+Private Sub TBezeichnung_Exit(Cancel As Integer)
+
+RefreshMain
+
+End Sub
+
+Sub RefreshMain()
+
+Dim gebietsnr As Long
+
+gebietsnr = CLng(Forms!FGebiete!TWBGNR)
+
+Forms!FGebietshierarchie.InitGebiete
+Forms!FGebietshierarchie!LGebiete = gebietsnr
+Forms!FGebietshierarchie.InitGrosslagen
+
+End Sub
+

wgmaster/vba/Form_FGebietshierarchie.frm

@@ -0,0 +1,345 @@
+Option Compare Database
+Option Explicit
+
+Private Sub BGebietBearbeiten_Click()
+
+DoCmd.OpenForm "FGebiete", acNormal, , "WBGNR=" + Format(LGebiete.Value), acFormEdit
+
+End Sub
+
+Private Sub BGebietLoeschen_Click()
+
+If MsgBox("Sind Sie sicher, daß Sie dieses Gebiet löschen wollen ?", vbYesNo) = vbYes Then
+
+
+Dim db1 As Database
+Dim rs1 As Recordset
+
+Set db1 = CurrentDb
+
+Set rs1 = db1.OpenRecordset("SELECT * FROM TGebiete WHERE WBGNR=" + Format(Forms!FGebietshierarchie!LGebiete) + ";")
+
+rs1.MoveFirst
+rs1.Delete
+rs1.Close
+
+LGebiete.SetFocus
+InitGebiete
+
+
+End If
+
+
+End Sub
+
+Private Sub BGebietNeu_Click()
+
+DoCmd.OpenForm "FGebiete", acNormal, , "RNR=" + Format(LRegionen.Value), acFormAdd
+
+End Sub
+
+Private Sub BGemeindeBearbeiten_Click()
+
+DoCmd.OpenForm "FGemeinden", acNormal, , "GNR=" + Format(LGemeinden.Value), acFormEdit
+
+End Sub
+
+Private Sub BGemeindeLoeschen_Click()
+
+If MsgBox("Sind Sie sicher, daß Sie diese Gemeinde löschen wollen ?", vbYesNo) = vbYes Then
+
+
+Dim db1 As Database
+Dim rs1 As Recordset
+
+Set db1 = CurrentDb
+
+Set rs1 = db1.OpenRecordset("SELECT * FROM TGemeinden WHERE GNR=" + Format(Forms!FGebietshierarchie!LGemeinden) + ";")
+
+rs1.MoveFirst
+rs1.Delete
+rs1.Close
+
+LGemeinden.SetFocus
+InitGemeinden
+
+End If
+
+
+
+End Sub
+
+Private Sub BGemeindeNeu_Click()
+
+DoCmd.OpenForm "FGemeinden", acNormal, , "GLNR=" + Format(LGrosslagen.Value), acFormAdd
+
+End Sub
+
+Private Sub BGrosslageBearbeiten_Click()
+
+DoCmd.OpenForm "FGrosslagen", acNormal, , "GLNR=" + Format(LGrosslagen.Value), acFormEdit
+
+End Sub
+
+Private Sub BGrosslageLoeschen_Click()
+
+If MsgBox("Sind Sie sicher, daß Sie diese Großlage löschen wollen ?", vbYesNo) = vbYes Then
+
+
+Dim db1 As Database
+Dim rs1 As Recordset
+
+Set db1 = CurrentDb
+
+Set rs1 = db1.OpenRecordset("SELECT * FROM TGrosslagen WHERE GLNR=" + Format(Forms!FGebietshierarchie!LGrosslagen) + ";")
+
+rs1.MoveFirst
+rs1.Delete
+rs1.Close
+
+LGrosslagen.SetFocus
+InitGrosslagen
+
+
+End If
+
+
+
+End Sub
+
+Private Sub BGrosslageNeu_Click()
+
+DoCmd.OpenForm "FGrosslagen", acNormal, , "WBGNR=" + Format(LGebiete.Value), acFormAdd
+
+End Sub
+
+Private Sub BRegionBearbeiten_Click()
+
+DoCmd.OpenForm "FRegionen", acNormal, , "RGNR=" + Format(LRegionen.Value), acFormEdit
+
+End Sub
+
+Private Sub BRegionLoeschen_Click()
+
+If MsgBox("Sind Sie sicher, daß Sie diese Region löschen wollen ?", vbYesNo) = vbYes Then
+
+
+Dim db1 As Database
+Dim rs1 As Recordset
+
+Set db1 = CurrentDb
+
+Set rs1 = db1.OpenRecordset("SELECT * FROM TRegionen WHERE RGNR=" + Format(Forms!FGebietshierarchie!LRegionen) + ";")
+
+rs1.MoveFirst
+rs1.Delete
+rs1.Close
+
+LRegionen.SetFocus
+InitRegionen
+
+
+End If
+
+
+End Sub
+
+Private Sub BRegionNeu_Click()
+
+DoCmd.OpenForm "FRegionen", acNormal, , , acFormAdd
+
+End Sub
+
+Private Sub BRiedBearbeiten_Click()
+
+DoCmd.OpenForm "FRiede", acNormal, , "RNR=" + Format(LRiede.Value), acFormEdit
+
+End Sub
+
+Private Sub BRiedLoeschen_Click()
+
+If MsgBox("Sind Sie sicher, daß Sie diesen Ried löschen wollen ?", vbYesNo) = vbYes Then
+
+
+Dim db1 As Database
+Dim rs1 As Recordset
+
+Set db1 = CurrentDb
+
+Set rs1 = db1.OpenRecordset("SELECT * FROM TRiede WHERE RNR=" + Format(Forms!FGebietshierarchie!LRiede) + ";")
+
+rs1.MoveFirst
+rs1.Delete
+rs1.Close
+
+LRiede.SetFocus
+InitRiede
+
+End If
+
+
+End Sub
+
+Private Sub BRiedNeu_Click()
+
+DoCmd.OpenForm "FRiede", acNormal, , "GNR=" + Format(LGemeinden.Value), acFormAdd
+
+End Sub
+
+Private Sub Form_Open(Cancel As Integer)
+
+InitRegionen
+
+End Sub
+
+
+Sub InitRegionen()
+
+'LRegionen.SetFocus
+BRegionNeu.Visible = True
+BRegionLoeschen.Visible = True
+BRegionBearbeiten.Visible = True
+
+LRegionen.Requery
+If LRegionen.ListCount > 0 Then
+  LRegionen = LRegionen.ItemData(0)
+  BGebietNeu.Visible = True
+  BRegionLoeschen.Visible = True
+  BRegionBearbeiten.Visible = True
+Else
+  LRegionen = -1
+  BRegionLoeschen.Visible = False
+  BRegionBearbeiten.Visible = False
+  BGebietNeu.Visible = False
+  BGebietBearbeiten.Visible = False
+  BGebietLoeschen.Visible = False
+End If
+
+InitGebiete
+
+End Sub
+
+Sub InitGebiete()
+
+
+LGebiete.Requery
+'LGebiete.SetFocus
+If LGebiete.ListCount > 0 Then
+ LGebiete = LGebiete.ItemData(0)
+ BGebietBearbeiten.Visible = True
+ BGebietLoeschen.Visible = True
+ BGrosslageNeu.Visible = True
+Else
+ LGebiete = -1
+ BGebietLoeschen.Visible = False
+ BGebietBearbeiten.Visible = False
+ BGrosslageNeu.Visible = False
+ BGrosslageLoeschen.Visible = False
+ BGrosslageBearbeiten.Visible = False
+End If
+
+InitGrosslagen
+
+End Sub
+
+Sub InitGrosslagen()
+
+LGrosslagen.Requery
+'LGrosslagen.SetFocus
+If LGrosslagen.ListCount > 0 Then
+ LGrosslagen = LGrosslagen.ItemData(0)
+ BGrosslageLoeschen.Visible = True
+ BGrosslageBearbeiten.Visible = True
+ BGemeindeNeu.Visible = True
+Else
+ LGrosslagen = -1
+ BGrosslageLoeschen.Visible = False
+ BGrosslageBearbeiten.Visible = False
+ BGemeindeNeu.Visible = False
+ BGemeindeLoeschen.Visible = False
+ BGemeindeBearbeiten.Visible = False
+End If
+
+InitGemeinden
+
+End Sub
+
+Sub InitGemeinden()
+
+'LGemeinden.SetFocus
+LGemeinden.Requery
+
+If LGemeinden.ListCount > 0 Then
+ LGemeinden = LGemeinden.ItemData(0)
+ BGemeindeLoeschen.Visible = True
+ BGemeindeBearbeiten.Visible = True
+ BRiedNeu.Visible = True
+Else
+ LGemeinden = -1
+ BGemeindeLoeschen.Visible = False
+ BGemeindeBearbeiten.Visible = False
+ BRiedNeu.Visible = False
+ BRiedLoeschen.Visible = False
+ BRiedBearbeiten.Visible = False
+End If
+
+InitRiede
+
+End Sub
+
+Sub InitRiede()
+
+LRiede.Requery
+'LRiede.SetFocus
+
+If LRiede.ListCount > 0 Then
+ LRiede = LRiede.ItemData(0)
+ BRiedLoeschen.Visible = True
+ BRiedBearbeiten.Visible = True
+Else
+ LRiede = -1
+ BRiedLoeschen.Visible = False
+ BRiedBearbeiten.Visible = False
+End If
+
+End Sub
+
+Private Sub LGebiete_Click()
+
+InitGrosslagen
+
+End Sub
+
+Private Sub LGemeinden_Click()
+
+InitRiede
+
+End Sub
+
+Private Sub LGrosslagen_Click()
+
+InitGemeinden
+
+End Sub
+
+Private Sub LRegionen_Click()
+
+InitGebiete
+
+End Sub
+Private Sub Befehl34_Click()
+On Error GoTo Err_Befehl34_Click
+
+    Dim stDocName As String
+
+    stDocName = "BGebietshierarchie"
+    DoCmd.OpenReport stDocName, acViewPreview
+
+Exit_Befehl34_Click:
+    Exit Sub
+
+Err_Befehl34_Click:
+    MsgBox Err.Description
+    Resume Exit_Befehl34_Click
+    
+End Sub

wgmaster/vba/Form_FGemeinden.frm

@@ -0,0 +1,27 @@
+Option Compare Database
+Option Explicit
+
+Private Sub Form_Close()
+
+RefreshMain
+
+End Sub
+
+Private Sub TBezeichnung_Exit(Cancel As Integer)
+
+RefreshMain
+
+End Sub
+
+Sub RefreshMain()
+
+Dim GNR As Long
+
+GNR = CLng(Forms!FGemeinden!TGNR)
+
+Forms!FGebietshierarchie.InitGemeinden
+Forms!FGebietshierarchie!LGemeinden = GNR
+Forms!FGebietshierarchie.InitRiede
+
+End Sub
+

wgmaster/vba/Form_FGrosslagen.frm

@@ -0,0 +1,27 @@
+Option Compare Database
+Option Explicit
+
+Private Sub Form_Close()
+
+RefreshMain
+
+End Sub
+
+Private Sub TBezeichnung_Exit(Cancel As Integer)
+
+RefreshMain
+
+End Sub
+
+Sub RefreshMain()
+
+Dim GLNR As Long
+
+GLNR = CLng(Forms!FGrosslagen!TGLNR)
+
+Forms!FGebietshierarchie.InitGrosslagen
+Forms!FGebietshierarchie!LGrosslagen = GLNR
+Forms!FGebietshierarchie.InitGemeinden
+
+End Sub
+

wgmaster/vba/Form_FGrosslagenGebieteSorten.frm

@@ -0,0 +1,4 @@
+Option Compare Database
+Option Explicit
+
+

wgmaster/vba/Form_FLeseplanung.frm

@@ -0,0 +1,52 @@
+Public Lesejahr As Integer
+
+
+Public Function GetLesejahr()
+
+GetLesejahr = Lesejahr
+
+End Function
+
+Public Sub SetLesejahr(Jahr1 As Integer)
+ Lesejahr = Jahr1
+ 
+End Sub
+
+Private Sub BLeseplanungDrucken_Click()
+
+
+DoCmd.OpenReport "BLeseplanung", acPreview, , "Year(Datum)=" + Format(Lesejahr)
+
+End Sub
+
+Private Sub TSNR_Exit(Cancel As Integer)
+
+    TSNR = UCase(TSNR)
+    
+    Dim SNR1 As String
+    Dim SANR1 As String
+
+
+    If IsNull(TSNR) Then
+     Exit Sub
+    End If
+    
+    If GetSNRAndSANRFromInput(TSNR, SNR1, SANR1) Then
+     TSNR = SNR1
+     TSANR = SANR1
+    Else
+     TSANR = Null
+    End If
+    
+    
+     If DCount("[SNR]", "TSorten", "SNR='" + TSNR + "'") = 0 Then
+      MsgBox "Bitte geben Sie ein gültiges Sortenkürzel ein!", vbCritical
+      'TSNR =
+      TSNR.SetFocus
+      Exit Sub
+     End If
+    
+    DoCmd.DoMenuItem acFormBar, acRecordsMenu, acSaveRecord, , acMenuVer70
+
+
+End Sub

wgmaster/vba/Form_FLiefermengen.frm

@@ -0,0 +1,69 @@
+
+Private Sub BSortenKuerzelUmbenennen_Click()
+
+DoCmd.OpenForm "FSortenkuerzelUmbenennen"
+
+End Sub
+
+Private Sub BAutomatischErstellen_Click()
+
+If MsgBox("Wollen Sie Liefermengeneinträge aufgrund der vorhandenen Flächenbindungen automatisch erstellen?", vbYesNo) = vbYes Then
+ 
+ Dim db1 As Database
+ Dim rs1 As Recordset
+ Dim rs2 As Recordset
+ Dim query1 As String
+ Set db1 = CurrentDb
+ Set rs1 = db1.OpenRecordset("SELECT DISTINCT SNR,SANR FROM TFlaechenbindungen WHERE SNR IS NOT NULL AND (Bis>" + Format(year(Date)) + " OR Bis is null)")
+ While Not rs1.EOF
+   If IsNull(rs1("SANR")) Then
+    query1 = "SELECT * FROM TLiefermengen WHERE SNR='" + rs1("SNR") + "' AND SANR IS NULL"
+   Else
+    query1 = "SELECT * FROM TLiefermengen WHERE SNR='" + rs1("SNR") + "' AND SANR='" + rs1("SANR") + "'"
+   End If
+
+   Set rs2 = db1.OpenRecordset(query1)
+   
+   If rs2.EOF Then
+   'there is no entry for this combination
+    rs2.AddNew
+    rs2("SNR") = rs1("SNR")
+    rs2("SANR") = rs1("SANR")
+    rs2("ErwarteteLiefermengeProHa") = 7500
+    rs2.Update
+   End If
+   
+   rs1.MoveNext
+ Wend
+ 
+ rs1.Close
+ rs2.Close
+ Requery
+
+
+End If
+
+End Sub
+
+Private Sub Form_Close()
+
+If Not IsNull(TKopftext) Then SetParameter "LIEFERMENGEKOPFTEXT", TKopftext
+If Not IsNull(TFusstext) Then SetParameter "LIEFERMENGEFUSSTEXT", TFusstext
+
+End Sub
+
+Private Sub Form_Open(Cancel As Integer)
+
+If Not IsNull(GetParameter("LIEFERMENGEKOPFTEXT")) Then
+ TKopftext = GetParameter("LIEFERMENGEKOPFTEXT")
+Else
+ TKopftext = "Auf Grund der Flächenbindung erwartet der Winzerkeller im Weinviertel reg.Gen.m.b.H. bei der Ernte 2014 von Ihnen eine Lieferung von mindestens"
+End If
+ 
+If Not IsNull(GetParameter("LIEFERMENGEKOPFTEXT")) Then
+ TFusstext = GetParameter("LIEFERMENGEFUSSTEXT")
+Else
+ TFusstext = "Bei Nichterfüllung muss mit der im Vertrag vereinbarten Pönnaleforderung gerechnet werden."
+End If
+
+End Sub

wgmaster/vba/Form_FLieferungAbschlag.frm

@@ -0,0 +1,19 @@
+Private Sub LGNR_Exit(Cancel As Integer)
+
+End Sub
+Private Sub Befehl46_Click()
+On Error GoTo Err_Befehl46_Click
+
+    Dim stDocName As String
+
+    stDocName = "BAbschlaege"
+    DoCmd.OpenReport stDocName, acViewPreview
+
+Exit_Befehl46_Click:
+    Exit Sub
+
+Err_Befehl46_Click:
+    MsgBox Err.Description
+    Resume Exit_Befehl46_Click
+    
+End Sub

wgmaster/vba/Form_FLieferungen.frm

@@ -0,0 +1,718 @@
+Public TheEvent As Integer
+
+Dim CNRAlt As Long
+
+
+Private Sub BAbwerten_Click()
+
+
+Dim wert1
+Dim Wert As Double
+Dim aktLieferscheinnummer
+Dim db1 As Database
+
+Dim rs1 As Recordset
+Dim rs2 As Recordset
+Dim rs3 As Recordset
+Dim rs4 As Recordset
+
+aktLieferscheinnummer = TLieferscheinnummer
+
+If OAbgewertet = True Then
+ MsgBox "Dieser Lieferschein wurde bereits abgewertet !", vbCritical
+ Exit Sub
+End If
+
+If OStorniert = True Then
+ MsgBox "Ein stornierter Lieferschein kann nicht abgewertet werden !", vbCritical
+ Exit Sub
+End If
+
+'If TOechsle < CLng(GetParameter("ABWERTUNGOECHSLE")) Then
+' MsgBox "Die Abwertung macht keinen Sinn, da Oechsle bereits niedriger", vbCritical
+' Exit Sub
+'End If
+
+wert1 = InputBox("Welchen Gewichtsanteil dieser Lieferung wollen Sie abwerten ?")
+
+If IsNull(wert1) Or wert1 = "" Then
+ MsgBox "Sie haben kein gültiges Gewicht eingegeben - Abwertung abgebrochen !", vbCritical
+ Exit Sub
+End If
+
+If wert1 > 0 Then
+ Wert = wert1
+ If Wert >= TGewicht Then
+  MsgBox ("Gesamte Lieferung abwerten")
+  OAbgewertet = True
+  TOechsleOriginal = TOechsle
+  TQSNROriginal = TQSNR
+  'CP 20070213: Oechslsereduktion bei Abwertung nur bedingt
+  'If Not IsNull(TSANR) And TSANR <> "" Then
+  '  If DFirst("AbwertungInAuszahlungIgnorieren", "TSortenattribute", "SANR='" + TSANR + "'") = True Then
+  '   'Keine Oechslereduktion
+  '  Else
+  '   TOechsle = GetParameter("ABWERTUNGOECHSLE")
+  '  End If
+  'Else
+  '  If DFirst("AbwertungInAuszahlungIgnorieren", "TSorten", "SNR='" + TSNR + "'") = True Then
+  '   'Keine Oechslereduktion
+  '  Else
+  '   TOechsle = GetParameter("ABWERTUNGOECHSLE")
+  '  End If
+  'End If
+  
+  TLieferscheinnummer = TLieferscheinnummer + "A"
+  'TQSNR = 1
+  'CP 20.11.2011: Änderung auf Qualitätsstufe 5 = 'Wein
+  TQSNR = 0
+  
+ Else
+  MsgBox ("Teil der Lieferung abwerten - Neuen Lieferschein erstellen")
+  Set db1 = CurrentDb
+  Set rs1 = db1.OpenRecordset("TLieferungen")
+  Set rs2 = db1.OpenRecordset("SELECT * FROM TLieferungen WHERE LINR=" + Format(TLINR))
+  rs1.AddNew
+
+  rs1!MGNR = rs2!MGNR
+  rs1!GNR = rs2!GNR
+  rs1!RNR = rs2!RNR
+  
+  rs1!ZNR = rs2!ZNR
+  rs1!SNR = rs2!SNR
+  If Not IsNull(rs2!SANR) Then
+   rs1!SANR = rs2!SANR
+  End If
+  rs1!Lieferscheinnummer = rs2!Lieferscheinnummer + "A"
+  rs1!Datum = rs2!Datum
+  rs1!Uhrzeit = rs2!Uhrzeit
+  rs1!Anmerkung = rs2!Anmerkung
+  rs1!Gerebelt = rs2!Gerebelt
+  
+  rs1!LINR = DMax("LINR", "TLieferungen") + 1
+  rs1!OechsleOriginal = rs2!Oechsle
+  rs1!Oechsle = rs2!Oechsle
+  
+  'CP 20070213: Oechslsereduktion bei Abwertung nur bedingt
+  'If Not IsNull(TSANR) And TSANR <> "" Then
+  '  If DFirst("AbwertungInAuszahlungIgnorieren", "TSortenattribute", "SANR='" + TSANR + "'") = True Then
+  '   'Keine Oechslereduktion
+  '   rs1!Oechsle = rs2!Oechsle
+  '  Else
+  '   rs1!Oechsle = GetParameter("ABWERTUNGOECHSLE")
+  '  End If
+  'Else
+  '  If DFirst("AbwertungInAuszahlungIgnorieren", "TSorten", "SNR='" + TSNR + "'") = True Then
+  '   'Keine Oechslereduktion
+  '   rs1!Oechsle = rs2!Oechsle
+  '  Else
+  '   rs1!Oechsle = GetParameter("ABWERTUNGOECHSLE")
+  '  End If
+  'End If
+  
+  rs1!Abgewertet = True
+  rs1!Gewicht = Wert
+  rs1!QSNROriginal = rs2!QSNR
+  rs1!QSNR = 0
+  'TQSNR = 1
+  'CP 20.11.2011: Änderung auf Qualitätsstufe 5 = 'Wein
+  'TQSNR = 0
+  rs1!Handwiegung = False
+  rs1!Storniert = False
+  
+  'Abschläge kopieren
+  Set rs3 = db1.OpenRecordset("SELECT * FROM TLieferungAbschlag WHERE LINR=" + Format(TLINR))
+  Set rs4 = db1.OpenRecordset("TLieferungAbschlag")
+  While Not rs3.EOF
+    rs4.AddNew
+    rs4!LINR = rs1!LINR
+    rs4!ASNR = rs3!ASNR
+    rs4.Update
+    rs3.MoveNext
+  Wend
+  rs3.Close
+  rs4.Close
+  
+  rs1.Update
+  rs1.Close
+  rs2.Close
+  TGewicht = TGewicht - Wert
+ End If
+End If
+
+Requery
+TLieferscheinnummer.SetFocus
+'DoCmd.FindRecord aktLieferscheinnummer, acEntire, , acSearchAll, , acCurrent
+
+
+
+End Sub
+
+Private Sub BAbwertenAlt_Click()
+
+
+Dim wert1
+Dim Wert As Double
+Dim aktLieferscheinnummer
+Dim db1 As Database
+
+Dim rs1 As Recordset
+Dim rs2 As Recordset
+Dim rs3 As Recordset
+Dim rs4 As Recordset
+
+aktLieferscheinnummer = TLieferscheinnummer
+
+If OAbgewertet = True Then
+ MsgBox "Dieser Lieferschein wurde bereits abgewertet !", vbCritical
+ Exit Sub
+End If
+
+If OStorniert = True Then
+ MsgBox "Ein stornierter Lieferschein kann nicht abgewertet werden !", vbCritical
+ Exit Sub
+End If
+
+If TOechsle < CLng(GetParameter("ABWERTUNGOECHSLE")) Then
+ MsgBox "Die Abwertung macht keinen Sinn, da Oechsle bereits niedriger", vbCritical
+ Exit Sub
+End If
+
+wert1 = InputBox("Welchen Gewichtsanteil dieser Lieferung wollen Sie abwerten ?")
+
+If IsNull(wert1) Or wert1 = "" Then
+ MsgBox "Sie haben kein gültiges Gewicht eingegeben - Abwertung abgebrochen !", vbCritical
+ Exit Sub
+End If
+
+If wert1 > 0 Then
+ Wert = wert1
+ If Wert >= TGewicht Then
+  MsgBox ("Gesamte Lieferung abwerten")
+  OAbgewertet = True
+  TOechsleOriginal = TOechsle
+  TQSNROriginal = TQSNR
+  'CP 20070213: Oechslsereduktion bei Abwertung nur bedingt
+  If Not IsNull(TSANR) And TSANR <> "" Then
+    If DFirst("AbwertungInAuszahlungIgnorieren", "TSortenattribute", "SANR='" + TSANR + "'") = True Then
+     'Keine Oechslereduktion
+    Else
+     TOechsle = GetParameter("ABWERTUNGOECHSLE")
+    End If
+  Else
+    If DFirst("AbwertungInAuszahlungIgnorieren", "TSorten", "SNR='" + TSNR + "'") = True Then
+     'Keine Oechslereduktion
+    Else
+     TOechsle = GetParameter("ABWERTUNGOECHSLE")
+    End If
+  End If
+  
+  TLieferscheinnummer = TLieferscheinnummer + "A"
+  'TQSNR = 1
+  'CP 20.11.2011: Änderung auf Qualitätsstufe 0 = 'Wein
+  TQSNR = 0
+  
+ Else
+  MsgBox ("Teil der Lieferung abwerten - Neuen Lieferschein erstellen")
+  Set db1 = CurrentDb
+  Set rs1 = db1.OpenRecordset("TLieferungen")
+  Set rs2 = db1.OpenRecordset("SELECT * FROM TLieferungen WHERE LINR=" + Format(TLINR))
+  rs1.AddNew
+
+  rs1!MGNR = rs2!MGNR
+  rs1!GNR = rs2!GNR
+  rs1!RNR = rs2!RNR
+  
+  rs1!ZNR = rs2!ZNR
+  rs1!SNR = rs2!SNR
+  If Not IsNull(rs2!SANR) Then
+   rs1!SANR = rs2!SANR
+  End If
+  rs1!Lieferscheinnummer = rs2!Lieferscheinnummer + "A"
+  rs1!Datum = rs2!Datum
+  rs1!Uhrzeit = rs2!Uhrzeit
+  rs1!Anmerkung = rs2!Anmerkung
+  rs1!Gerebelt = rs2!Gerebelt
+  
+  rs1!LINR = DMax("LINR", "TLieferungen") + 1
+  rs1!OechsleOriginal = rs2!Oechsle
+  
+  'CP 20070213: Oechslsereduktion bei Abwertung nur bedingt
+  If Not IsNull(TSANR) And TSANR <> "" Then
+    If DFirst("AbwertungInAuszahlungIgnorieren", "TSortenattribute", "SANR='" + TSANR + "'") = True Then
+     'Keine Oechslereduktion
+     rs1!Oechsle = rs2!Oechsle
+    Else
+     rs1!Oechsle = GetParameter("ABWERTUNGOECHSLE")
+    End If
+  Else
+    If DFirst("AbwertungInAuszahlungIgnorieren", "TSorten", "SNR='" + TSNR + "'") = True Then
+     'Keine Oechslereduktion
+     rs1!Oechsle = rs2!Oechsle
+    Else
+     rs1!Oechsle = GetParameter("ABWERTUNGOECHSLE")
+    End If
+  End If
+  
+  rs1!Abgewertet = True
+  rs1!Gewicht = Wert
+  rs1!QSNROriginal = rs2!QSNR
+  rs1!QSNR = 0
+  'TQSNR = 1
+  'CP 20.11.2011: Änderung auf Qualitätsstufe 0 = 'Wein
+  'TQSNR = 0
+  rs1!Handwiegung = False
+  rs1!Storniert = False
+  
+  'Abschläge kopieren
+  Set rs3 = db1.OpenRecordset("SELECT * FROM TLieferungAbschlag WHERE LINR=" + Format(TLINR))
+  Set rs4 = db1.OpenRecordset("TLieferungAbschlag")
+  While Not rs3.EOF
+    rs4.AddNew
+    rs4!LINR = rs1!LINR
+    rs4!ASNR = rs3!ASNR
+    rs4.Update
+    rs3.MoveNext
+  Wend
+  rs3.Close
+  rs4.Close
+  
+  rs1.Update
+  rs1.Close
+  rs2.Close
+  TGewicht = TGewicht - Wert
+ End If
+End If
+
+Requery
+TLieferscheinnummer.SetFocus
+'DoCmd.FindRecord aktLieferscheinnummer, acEntire, , acSearchAll, , acCurrent
+
+
+
+End Sub
+
+Private Sub Befehl114_Click()
+
+Dim Wert
+
+Wert = InputBox("Geben Sie bitte das Gewicht an:", "Manuelle Gewichtseingabe")
+
+If Wert <> "" And Not IsNull(Wert) Then
+
+TGewicht.SetFocus
+TGewicht = Wert
+
+OHandwiegung = 1
+
+DoCmd.DoMenuItem acFormBar, acRecordsMenu, acSaveRecord, , acMenuVer70
+RefreshAll
+End If
+
+End Sub
+
+
+
+Private Sub Befehl170_Click()
+
+Dim str1 As String
+Dim rnr1 As Long
+
+str1 = InputBox("Bitte geben Sie die Riedbezeichnung ein:")
+
+If str1 <> "" And Not IsNull(str1) Then
+
+Dim db1 As Database
+Dim rs1 As Recordset
+
+Set db1 = CurrentDb
+Set rs1 = db1.OpenRecordset("SELECT * FROM TRiede;")
+
+rs1.AddNew
+rnr1 = DMax("[RNR]", "TRiede") + 1
+rs1!RNR = rnr1
+rs1!GNR = Forms!FLieferungen!TGNR
+rs1!Bezeichnung = str1
+rs1.Update
+rs1.Close
+TRNR.Requery
+TRNR = rnr1
+
+
+End If
+
+
+End Sub
+
+Private Sub Befehl183_Click()
+
+If Not IsNull(TMGNR) And TMGNR <> "" Then
+  DoCmd.OpenForm "FMitgliedInfo"
+End If
+
+End Sub
+
+
+
+
+
+
+
+Private Sub Befehl194_Click()
+
+End Sub
+
+Private Sub BVorschau_Click()
+
+Dim LieferscheinName As String
+
+If IsNull(GetParameter("LIEFERSCHEINART")) Then
+ SetParameter "LIEFERSCHEINART", "2"
+End If
+
+LieferscheinName = "BLieferschein" + GetParameter("LIEFERSCHEINART")
+DoCmd.OpenReport LieferscheinName, acViewPreview, , "[LINR]=" + Format(Forms!FLieferungen!TLINR)
+
+'    If GetParameter("LIEFERSCHEINART") = "1" Then
+'      DoCmd.OpenReport "BLieferschein1", , , "[LINR]=" + Format(Forms!FLieferungen!TLINR)
+'     Else
+'      DoCmd.OpenReport "BLieferschein2", , , "[LINR]=" + Format(Forms!FLieferungen!TLINR)
+'     End If
+
+End Sub
+
+Private Sub Form_Activate()
+
+RefreshAll
+
+End Sub
+
+
+
+
+Private Sub Kombinationsfeld105_Change()
+
+TSNR = TSorte
+
+End Sub
+
+
+
+Private Sub Form_Current()
+
+RefreshAll
+TMGNR.SetFocus
+
+End Sub
+
+Private Sub Form_Load()
+'TOechsle.SetFocus
+
+If Not IsNull(DFirst("LINR", "TLieferungen")) Then
+ DoCmd.GoToRecord acActiveDataObject, , acLast
+ RefreshAll
+Else
+ MsgBox ("Keine Lieferungen vorhanden !")
+ 'Forms!FLieferungen.Close
+End If
+'TMGNR.SetFocus
+
+
+End Sub
+
+Private Sub Kombinationsfeld125_Exit(Cancel As Integer)
+
+End Sub
+
+
+
+Private Sub LBishergeliefert_DblClick(Cancel As Integer)
+
+Dim LINR1
+If Not IsNull(LBishergeliefert) Then
+ 'TLieferscheinnummer.SetFocus
+ LINR1 = LBishergeliefert
+ Forms!FLieferungen.RecordSource = "SELECT TMitglieder.Nachname, TMitglieder.Vorname, TMitglieder.Telefon, TMitglieder.Geschäftsanteile1, TMitglieder.Geschäftsanteile2, TMitglieder.[Aktives Mitglied], TMitglieder.Eintrittsdatum, TMitglieder.Austrittsdatum, TMitglieder.Ort, TMitglieder.Straße, TLieferungen.* FROM TMitglieder RIGHT JOIN TLieferungen ON TMitglieder.MGNR = TLieferungen.MGNR WHERE LINR=" + Format(LINR1)
+End If
+
+End Sub
+
+
+Private Sub OSpaetlese_Click()
+
+Dim Oechsle As Long
+Dim QSNR As Long
+Oechsle = CLng(TOechsle.Value)
+QSNR = DFirst("QSNR", "TQualitaetsstufen", "Von<=" + Format(Oechsle) + " AND Bis>=" + Format(Oechsle))
+
+If QSNR = 5 Then
+ If OSpaetlese.Value = True Then
+  TQSNR = 5
+ Else
+  TQSNR = 3
+ End If
+End If
+
+DoCmd.DoMenuItem acFormBar, acRecordsMenu, acSaveRecord, , acMenuVer70
+RefreshAll
+
+
+End Sub
+
+Private Sub TCNR_Click()
+
+DoCmd.DoMenuItem acFormBar, acRecordsMenu, acSaveRecord, , acMenuVer70
+If MsgBox("Soll sich die nachträgliche Chargenzuordnung auch auf die Chargenmengen auswirken?", vbYesNo) Then
+ ChargenLieferungenZuordnungÄndern TLINR, CNRAlt, TCNR
+End If
+
+
+End Sub
+
+Private Sub TCNR_GotFocus()
+CNRAlt = TCNR
+End Sub
+
+Private Sub TGewicht_Exit(Cancel As Integer)
+
+DoCmd.DoMenuItem acFormBar, acRecordsMenu, acSaveRecord, , acMenuVer70
+RefreshAll
+
+End Sub
+
+
+
+
+Private Sub TGNR_Exit(Cancel As Integer)
+
+DoCmd.DoMenuItem acFormBar, acRecordsMenu, acSaveRecord, , acMenuVer70
+RefreshAll
+TRNR.Requery
+
+End Sub
+
+Private Sub TMitglied_Click()
+
+TMGNR = TMitglied
+
+End Sub
+
+Private Sub TOechsle_Exit(Cancel As Integer)
+        
+If IsNull(TOechsle) Or TOechsle = 0 Or TOechsle = "" Then
+Else
+ TQSNR.Value = DFirst("QSNR", "TQualitaetsstufen", "Von<=" + Format(TOechsle) + " AND Bis>=" + Format(TOechsle))
+End If
+ DoCmd.DoMenuItem acFormBar, acRecordsMenu, acSaveRecord, , acMenuVer70
+ RefreshAll
+
+End Sub
+
+Sub RefreshAll()
+
+Dim w1
+
+w1 = TOechsle
+
+If Not IsNull(w1) And w1 <> "" Then
+ 'TQualitaetsstufe.Caption = DMax("Bezeichnung", "TQualitaetsstufen", "QSNR=" + Format(TQSNR))
+ If Qualitätsstufe(CDbl(w1)) = "Spätlese" Then
+  OSpaetlese.Visible = True
+ Else
+  OSpaetlese.Visible = False
+ End If
+ TKW.Caption = "= " + Format((DMax("[KW]", "TUmrechnung", "Oechsle=" + Format(TOechsle)))) + " ° KW"
+Else
+ 'TQualitaetsstufe.Caption = ""
+ TKW.Caption = ""
+End If
+
+If Not IsNull(TGNR) Then
+ TGLNR = DFirst("[GLNR]", "TGemeinden", "GNR=" + Format(TGNR))
+ TWBGNR = GetGebietGLNR(TSNR, TQSNR, TGLNR)
+ 'TWBGNR = DFirst("[WBGNR]", "TGrosslagen", "GLNR=" + Format(TGLNR))
+ TRGNR = DFirst("[RGNR]", "TGebiete", "WBGNR=" + Format(TWBGNR))
+End If
+
+
+LBishergeliefert.Requery
+
+End Sub
+
+
+Private Sub Befehl133_Click()
+On Error GoTo Err_Befehl133_Click
+
+
+    DoCmd.GoToRecord , , acFirst
+
+Exit_Befehl133_Click:
+    Exit Sub
+
+Err_Befehl133_Click:
+    MsgBox Err.Description
+    Resume Exit_Befehl133_Click
+    
+End Sub
+Private Sub Befehl134_Click()
+On Error GoTo Err_Befehl134_Click
+
+
+    DoCmd.GoToRecord , , acPrevious
+
+Exit_Befehl134_Click:
+    Exit Sub
+
+Err_Befehl134_Click:
+    MsgBox Err.Description
+    Resume Exit_Befehl134_Click
+    
+End Sub
+Private Sub Befehl135_Click()
+On Error GoTo Err_Befehl135_Click
+
+
+    DoCmd.GoToRecord , , acNext
+
+Exit_Befehl135_Click:
+    Exit Sub
+
+Err_Befehl135_Click:
+    MsgBox Err.Description
+    Resume Exit_Befehl135_Click
+    
+End Sub
+Private Sub Befehl136_Click()
+On Error GoTo Err_Befehl136_Click
+
+
+    DoCmd.GoToRecord , , acLast
+
+Exit_Befehl136_Click:
+    Exit Sub
+
+Err_Befehl136_Click:
+    MsgBox Err.Description
+    Resume Exit_Befehl136_Click
+    
+End Sub
+Private Sub Befehl137_Click()
+
+On Error GoTo Err_Befehl137_Click
+
+
+    DoCmd.GoToRecord , , acNewRec
+
+Exit_Befehl137_Click:
+    Exit Sub
+
+Err_Befehl137_Click:
+    MsgBox Err.Description
+    Resume Exit_Befehl137_Click
+    
+TMGNR.SetFocus
+
+
+End Sub
+Private Sub Befehl138_Click()
+
+If MsgBox("Sind Sie sicher, daß Sie diesen Datensatz löschen möchten (ev. stornieren) ?", vbYesNo) = vbYes Then
+
+On Error GoTo Err_Befehl138_Click
+
+
+    DoCmd.DoMenuItem acFormBar, acEditMenu, 8, , acMenuVer70
+    DoCmd.DoMenuItem acFormBar, acEditMenu, 6, , acMenuVer70
+
+Exit_Befehl138_Click:
+    Exit Sub
+
+Err_Befehl138_Click:
+    MsgBox Err.Description
+        Resume Exit_Befehl138_Click
+    
+    
+End If
+
+End Sub
+
+Private Sub Befehl141_Click()
+
+If MsgBox("Wollen Sie diese Lieferung wirklich stornieren ?", vbYesNo) = vbYes Then
+
+ If Not IsNull(TCNR) And TGewicht > 0 And TOechsle > 0 Then
+  If MsgBox("Wollen Sie die Liefermenge bei der zugeordneten Charge ebenfalls abziehen?", vbYesNo) = vbYes Then
+    ChargeBefuellungRueckgaengig TCNR, TLINR
+    TCNR = ""
+  End If
+ End If
+ 
+ TGewicht = 0
+ OStorniert = 1
+ DoCmd.DoMenuItem acFormBar, acRecordsMenu, acSaveRecord, , acMenuVer70
+ RefreshAll
+ 
+End If
+    
+    
+End Sub
+
+Private Sub TSNR_Exit(Cancel As Integer)
+
+Dim SNR1 As String
+Dim SANR1 As String
+
+
+If IsNull(TSNR) Then
+ Exit Sub
+End If
+
+If GetSNRAndSANRFromInput(TSNR, SNR1, SANR1) Then
+ TSNR = SNR1
+ TSANR = SANR1
+Else
+ TSANR = Null
+End If
+
+If DCount("[SNR]", "TSorten", "SNR='" + TSNR + "'") = 0 Then
+ MsgBox "Bitte geben Sie ein gültiges Sortenkürzel ein!", vbCritical
+ 'TSNR =
+ TSNR.SetFocus
+ Exit Sub
+End If
+
+
+    DoCmd.DoMenuItem acFormBar, acRecordsMenu, acSaveRecord, , acMenuVer70
+    RefreshAll
+End Sub
+
+
+
+Private Sub Befehl175_Click()
+
+Dim LieferscheinName As String
+
+If GetParameter("LIEFERSCHEINART") = Null Then
+ SetParameter "LIEFERSCHEINART", 2
+End If
+
+LieferscheinName = "BLieferschein" + GetParameter("LIEFERSCHEINART")
+DoCmd.OpenReport LieferscheinName, , , "[LINR]=" + Format(Forms!FLieferungen!TLINR)
+
+'    If GetParameter("LIEFERSCHEINART") = "1" Then
+'      DoCmd.OpenReport "BLieferschein1", , , "[LINR]=" + Format(Forms!FLieferungen!TLINR)
+'     Else
+'      DoCmd.OpenReport "BLieferschein2", , , "[LINR]=" + Format(Forms!FLieferungen!TLINR)
+'     End If
+            
+End Sub
+
+
+
+
+
+Private Sub Befehl186_Click()
+    
+DoCmd.OpenForm "MLieferungSuchen"
+    
+End Sub

wgmaster/vba/Form_FMandant.frm

@@ -0,0 +1,61 @@
+Option Compare Database
+Option Explicit
+
+Private Sub Kombinationsfeld39_Change()
+
+TBlz = TBank
+
+End Sub
+
+Private Sub Form_Close()
+
+If Not IsNull(TName1) Then SetParameter "MANDANTENNAME1", TName1
+If Not IsNull(TName2) Then SetParameter "MANDANTENNAME2", TName2
+If Not IsNull(TStrasse) Then SetParameter "MANDANTENSTRASSE", TStrasse
+If Not IsNull(TPLZ) Then SetParameter "MANDANTENPLZ", TPLZ
+If Not IsNull(TOrt) Then SetParameter "MANDANTENORT", TOrt
+If Not IsNull(TTelefon) Then SetParameter "MANDANTENTELEFON", TTelefon
+If Not IsNull(TTelefax) Then SetParameter "MANDANTENTELEFAX", TTelefax
+If Not IsNull(TDvr) Then SetParameter "MANDANTENDVR", TDvr
+If Not IsNull(TBetriebsnummer) Then SetParameter "MANDANTENBETRIEBSNUMMER", TBetriebsnummer
+If Not IsNull(TBlz) Then SetParameter "MANDANTENBLZ", TBlz
+If Not IsNull(TKontonummer) Then SetParameter "MANDANTENKONTONUMMER", TKontonummer
+If Not IsNull(TUID) Then SetParameter "MANDANTENUID", TUID
+If Not IsNull(TEMail) Then SetParameter "MANDANTENEMAIL", TEMail
+If Not IsNull(THomepage) Then SetParameter "MANDANTENHOMEPAGE", THomepage
+
+End Sub
+
+Private Sub Form_Open(Cancel As Integer)
+
+
+If Not IsNull(GetParameter("MANDANTENNAME1")) Then TName1 = GetParameter("MANDANTENNAME1")
+If Not IsNull(GetParameter("MANDANTENNAME2")) Then TName2 = GetParameter("MANDANTENNAME2")
+If Not IsNull(GetParameter("MANDANTENSTRASSE")) Then TStrasse = GetParameter("MANDANTENSTRASSE")
+If Not IsNull(GetParameter("MANDANTENPLZ")) Then TPLZ = GetParameter("MANDANTENPLZ")
+If Not IsNull(GetParameter("MANDANTENORT")) Then TOrt = GetParameter("MANDANTENORT")
+If Not IsNull(GetParameter("MANDANTENTELEFON")) Then TTelefon = GetParameter("MANDANTENTELEFON")
+If Not IsNull(GetParameter("MANDANTENTELEFAX")) Then TTelefax = GetParameter("MANDANTENTELEFAX")
+If Not IsNull(GetParameter("MANDANTENDVR")) Then TDvr = GetParameter("MANDANTENDVR")
+If Not IsNull(GetParameter("MANDANTENBETRIEBSNUMMER")) Then TBetriebsnummer = GetParameter("MANDANTENBETRIEBSNUMMER")
+If Not IsNull(GetParameter("MANDANTENBLZ")) Then TBlz = GetParameter("MANDANTENBLZ")
+If Not IsNull(GetParameter("MANDANTENBLZ")) Then TBank = GetParameter("MANDANTENBLZ")
+If Not IsNull(GetParameter("MANDANTENKONTONUMMER")) Then TKontonummer = GetParameter("MANDANTENKONTONUMMER")
+If Not IsNull(GetParameter("MANDANTENUID")) Then TUID = GetParameter("MANDANTENUID")
+If Not IsNull(GetParameter("MANDANTENEMAIL")) Then TEMail = GetParameter("MANDANTENEMAIL")
+If Not IsNull(GetParameter("MANDANTENHOMEPAGE")) Then THomepage = GetParameter("MANDANTENHOMEPAGE")
+
+
+End Sub
+
+Private Sub TBank_Change()
+
+TBlz = TBank
+
+End Sub
+
+Private Sub TBlz_Exit(Cancel As Integer)
+
+TBank = TBlz
+
+End Sub

wgmaster/vba/Form_FMitgliedInfo.frm

@@ -0,0 +1,10 @@
+
+Private Sub Form_Activate()
+
+filter = "MGNR=" + Format(Forms!FLieferungen!TMGNR)
+
+FilterOn = True
+
+
+End Sub
+

wgmaster/vba/Form_FMitglieder.frm

@@ -0,0 +1,288 @@
+Option Compare Database
+Option Explicit
+
+Dim select1 As String
+Dim where1 As String
+Dim order1 As String
+
+
+
+
+
+Private Sub Befehl81_Click()
+
+
+ DoCmd.DoMenuItem acFormBar, acRecordsMenu, acSaveRecord, , acMenuVer70
+ DoCmd.OpenForm "MMitgliederliste"
+
+End Sub
+
+Private Sub Befehl86_Click()
+
+order1 = " ORDER BY MGNR;"
+RequeryListe
+
+End Sub
+
+Private Sub Befehl87_Click()
+
+order1 = " ORDER BY Nachname,Vorname;"
+RequeryListe
+
+End Sub
+
+Private Sub BLöschen_Click()
+
+If MsgBox("Wollen Sie dieses Mitglied wirklich löschen ?", vbYesNo) = vbYes Then
+  DoCmd.DoMenuItem acFormBar, acEditMenu, 8, , acMenuVer70
+  DoCmd.DoMenuItem acFormBar, acEditMenu, 6, , acMenuVer70
+  LMitglieder.Requery
+End If
+
+End Sub
+
+Private Sub BNeu_Click()
+
+Dim str1 As String
+Dim mgnr1 As Long
+
+str1 = InputBox("Bitte geben Sie den Familiennamen des Mitglieds ein:")
+If str1 <> "" Then
+DoCmd.GoToRecord , , acNewRec
+TNachname.SetFocus
+TNachname = str1
+TMGNR.SetFocus
+mgnr1 = TMGNR
+TVorname.SetFocus
+DoCmd.DoMenuItem acFormBar, acRecordsMenu, acSaveRecord, , acMenuVer70
+'DoCmd.GoToRecord , , acPrevious
+LMitglieder.Requery
+LMitglieder = mgnr1
+
+End If
+
+
+End Sub
+
+Private Sub BSuchen_Click()
+
+Dim suchstring
+Dim rs1 As Recordset
+Dim db1 As Database
+Dim where2 As String
+
+suchstring = InputBox("Geben Sie bitte den Suchbegriff ein: ")
+
+If IsNull(suchstring) Or suchstring = "" Then
+ where1 = ""
+Else
+ Set db1 = CurrentDb
+ Set rs1 = db1.OpenRecordset("SELECT * FROM TMitglieder")
+ 
+ If OAlleMitglieder = False Then
+  where1 = " WHERE [Aktives Mitglied]=True AND MGNR IN (-1,"
+ Else
+  where1 = " WHERE MGNR IN (-1,"
+ End If
+ 
+ suchstring = UCase(suchstring)
+
+ While Not rs1.EOF
+    If InStr(UCase(rs1!Nachname), suchstring) > 0 Or InStr(UCase(rs1!Vorname), suchstring) > 0 Or InStr(UCase(rs1!Ort), suchstring) > 0 Or InStr(UCase(Format(rs1!MGNR)), suchstring) > 0 Then
+     where1 = where1 + Format(rs1!MGNR) + ","
+    End If
+    rs1.MoveNext
+ Wend
+ rs1.Close
+ where1 = Left(where1, Len(where1) - 1) + ")"
+
+End If
+'MsgBox (where1)
+
+RequeryListe
+
+
+End Sub
+
+Private Sub Form_Open(Cancel As Integer)
+
+LMitglieder = TMGNR
+OAlleMitglieder = False
+select1 = "SELECT TMitglieder.MGNR, [Nachname]+IIf(IsNull([Vorname]),'',' '+[Vorname]) AS Name1, MGNR FROM TMitglieder "
+where1 = " WHERE [Aktives Mitglied]=true "
+order1 = " ORDER BY Nachname,Vorname;"
+LMitglieder.SetFocus
+LMitglieder.Value = LMitglieder.ItemData(0)
+TMGNR.SetFocus
+DoCmd.FindRecord Forms!FMitglieder!LMitglieder, acEntire, , , , acCurrent, True
+'DoCmd.FindRecord Forms!FMitglieder!LMitglieder, acEntire, , , , acCurrent, True
+
+End Sub
+
+Private Sub LMitglieder_Click()
+
+'Filter = "MGNR=Forms!FMitglieder.LMitglieder"
+'FilterOn = True
+
+TMGNR.SetFocus
+DoCmd.FindRecord Forms!FMitglieder!LMitglieder, acEntire, , , , acCurrent, True
+LMitglieder.SetFocus
+
+End Sub
+
+
+
+Private Sub OAlleMitglieder_Click()
+
+If OAlleMitglieder = False Then
+ where1 = " WHERE [Aktives Mitglied]=True "
+Else
+ where1 = ""
+End If
+
+RequeryListe
+
+
+End Sub
+
+
+
+
+
+
+
+Private Sub Text70_Exit(Cancel As Integer)
+
+If Text70.Value <> "" Then
+If MsgBox("Ist das Mitglied noch aktiv ?", vbYesNo) = vbYes Then
+ KAM.Value = 1
+Else
+ KAM.Value = 0
+End If
+End If
+
+End Sub
+Private Sub Befehl80_Click()
+ 
+ DoCmd.DoMenuItem acFormBar, acRecordsMenu, acSaveRecord, , acMenuVer70
+ 
+ SetParameter "STAMMBLATTTEXT", " "
+DoCmd.OpenReport "BMitgliedStammblattMGNR", acViewPreview, , "TMitglieder.MGNR=" + Format(TMGNR)
+
+If GetParameter("LIEFERMENGENDRUCKEN") = "1" Then
+
+ If DSum("Flaeche", "TFlaechenbindungen", "MGNR=" + Format(TMGNR) + " AND (Bis>=Year(Date()) OR Bis IS NULL)") > 0 Then
+  DoCmd.OpenReport "BLiefermenge", acViewPreview, , "TMitglieder.MGNR=" + Format(TMGNR)
+ End If
+
+End If
+
+
+'DoCmd.OpenForm "MStammblatt"
+'Forms!MStammblatt!TVon1 = TMGNR
+'Forms!MStammblatt!TBis1 = TMGNR
+'DoCmd.OpenReport "BMitgliedStammblatt", acViewPreview
+
+End Sub
+
+Private Sub TMGNR_DblClick(Cancel As Integer)
+
+Dim mgnr1 As Long
+
+mgnr1 = InputBox("Nach welcher Mitgliedsnummer soll gesucht werden ?", "Mitgliedssuche nach MGNR")
+
+LMitglieder = mgnr1
+
+TMGNR.SetFocus
+DoCmd.FindRecord Forms!FMitglieder!LMitglieder, acEntire, , , , acCurrent, True
+LMitglieder.SetFocus
+
+
+
+End Sub
+
+Private Sub TMGNR_Exit(Cancel As Integer)
+
+DoCmd.DoMenuItem acFormBar, acRecordsMenu, acSaveRecord, , acMenuVer70
+
+End Sub
+
+Private Sub TMGNRV_Exit(Cancel As Integer)
+
+Dim Jahr1 As Long
+Dim mgnr1 As Long
+
+DoCmd.DoMenuItem acFormBar, acRecordsMenu, acSaveRecord, , acMenuVer70
+
+If Not IsNull(TMGNRV) And TMGNRV <> 0 Then
+ If DCount("FBNR", "TFlaechenbindungen", "MGNR=" + Format(TMGNRV)) > 0 Then
+    If MsgBox("Wollen Sie bestehende Flächenbindungen des Vorgängers übernehmen ?", vbYesNo) = vbYes Then
+      Jahr1 = 0
+      While Jahr1 < 1900 Or Jahr1 > 2500
+       Jahr1 = InputBox("Übergabejahr:")
+      Wend
+      Dim db1 As Database
+      Dim rs1 As Recordset 'old member
+      Dim rs2 As Recordset 'new member
+      Set db1 = CurrentDb
+      Set rs1 = db1.OpenRecordset("SELECT * FROM TFlaechenbindungen WHERE MGNR=" + Format(TMGNRV))
+      Set rs2 = db1.OpenRecordset("SELECT * FROM TFlaechenbindungen WHERE MGNR=" + Format(TMGNR))
+      While Not rs1.EOF
+       ' new record
+        rs2.AddNew
+        rs2!MGNR = TMGNR
+        rs2!GNR = rs1!GNR
+        rs2!RNR = rs1!RNR
+        rs2!SNR = rs1!SNR
+        rs2!SANR = rs1!SANR
+        rs2!Parzellennummer = rs1!Parzellennummer
+        rs2!Flaeche = rs1!Flaeche
+        rs2!BANR = rs1!BANR
+        rs2!Von = Jahr1
+        rs2!Bis = rs1!Bis
+        rs2!FBNR = DMax("[FBNR]", "TFlaechenbindungen") + 1
+        rs2.Update
+        ' change old record: Bis
+        rs1.Edit
+        rs1!Bis = Jahr1 - 1
+        rs1.Update
+        rs1.MoveNext
+      Wend
+      rs1.Close
+      rs2.Close
+      mgnr1 = TMGNR
+      FUnter.Requery
+     End If
+  End If
+End If
+
+End Sub
+
+Private Sub TNachname_Exit(Cancel As Integer)
+
+DoCmd.DoMenuItem acFormBar, acRecordsMenu, acSaveRecord, , acMenuVer70
+LMitglieder.Requery
+LMitglieder = TMGNR
+
+End Sub
+
+
+Sub RequeryListe()
+
+Dim mgnr1 As Long
+
+mgnr1 = TMGNR
+LMitglieder.RowSource = select1 + where1 + order1
+LMitglieder.Requery
+LMitglieder = mgnr1
+LMitglieder.SetFocus
+
+End Sub
+
+Private Sub TVorname_Exit(Cancel As Integer)
+
+DoCmd.DoMenuItem acFormBar, acRecordsMenu, acSaveRecord, , acMenuVer70
+LMitglieder.Requery
+LMitglieder = TMGNR
+
+End Sub

wgmaster/vba/Form_FQualitaetsstufen.frm

@@ -0,0 +1,19 @@
+Private Sub LGNR_Exit(Cancel As Integer)
+
+End Sub
+Private Sub Befehl48_Click()
+On Error GoTo Err_Befehl48_Click
+
+    Dim stDocName As String
+
+    stDocName = "BQualitätsstufen"
+    DoCmd.OpenReport stDocName, acViewPreview
+
+Exit_Befehl48_Click:
+    Exit Sub
+
+Err_Befehl48_Click:
+    MsgBox Err.Description
+    Resume Exit_Befehl48_Click
+    
+End Sub

wgmaster/vba/Form_FRegionen.frm

@@ -0,0 +1,27 @@
+Option Compare Database
+Option Explicit
+
+Private Sub Form_Close()
+
+RefreshMain
+
+End Sub
+
+Private Sub TBezeichnung_Exit(Cancel As Integer)
+
+RefreshMain
+
+End Sub
+
+Sub RefreshMain()
+
+Dim Regionsnr As Long
+
+Regionsnr = CLng(Forms!FRegionen!TRGNR)
+
+Forms!FGebietshierarchie.InitRegionen
+Forms!FGebietshierarchie!LRegionen = Regionsnr
+Forms!FGebietshierarchie.InitGebiete
+
+End Sub
+

wgmaster/vba/Form_FRiede.frm

@@ -0,0 +1,26 @@
+Option Compare Database
+Option Explicit
+
+Private Sub Form_Close()
+
+RefreshMain
+
+End Sub
+
+Private Sub TBezeichnung_Exit(Cancel As Integer)
+
+RefreshMain
+
+End Sub
+
+Sub RefreshMain()
+
+Dim RNR As Long
+
+RNR = CLng(Forms!FRiede!TRNR)
+
+Forms!FGebietshierarchie.InitRiede
+Forms!FGebietshierarchie!LRiede = RNR
+
+End Sub
+

wgmaster/vba/Form_FRiedeMitglied.frm

@@ -0,0 +1,42 @@
+Option Compare Database
+Option Explicit
+
+Private Sub Form_Close()
+
+AddNewRied
+
+End Sub
+
+Private Sub Form_Open(Cancel As Integer)
+
+LGNR = Forms!FMitglieder!FUnter.Form![LGNR]
+If DCount("RNR", "TRiede", "") = 0 Then
+ TRNR = 1
+Else
+ TRNR = DMax("RNR", "TRiede", "") + 1
+End If
+TWGBZS = 0
+
+End Sub
+
+
+Sub AddNewRied()
+
+Dim db1 As Database
+Dim rs1 As Recordset
+
+If Not IsNull(TBezeichnung) Then
+
+  Set db1 = CurrentDb
+  Set rs1 = db1.OpenRecordset("TRiede")
+  rs1.AddNew
+  rs1!RNR = TRNR
+  rs1!GNR = LGNR
+  rs1!Bezeichnung = TBezeichnung
+  rs1!RZS = TWGBZS
+  rs1.Update
+  [Forms]![FMitglieder]![FUnter].[Form]![LRiede] = TRNR
+End If
+
+
+End Sub

wgmaster/vba/Form_FSorten.frm

@@ -0,0 +1,25 @@
+Private Sub LGNR_Exit(Cancel As Integer)
+
+End Sub
+Private Sub Befehl46_Click()
+On Error GoTo Err_Befehl46_Click
+
+    Dim stDocName As String
+
+    stDocName = "BSorten"
+    DoCmd.OpenReport stDocName, acViewPreview
+
+Exit_Befehl46_Click:
+    Exit Sub
+
+Err_Befehl46_Click:
+    MsgBox Err.Description
+    Resume Exit_Befehl46_Click
+    
+End Sub
+
+Private Sub BSortenKuerzelUmbenennen_Click()
+
+DoCmd.OpenForm "FSortenkuerzelUmbenennen"
+
+End Sub

wgmaster/vba/Form_FSortenAttribute.frm

@@ -0,0 +1,7 @@
+
+
+Private Sub BEingabe_Click()
+
+DoCmd.OpenForm "FSortenAttributeEingabe"
+
+End Sub

wgmaster/vba/Form_FSortenAttributeEingabe.frm

@@ -0,0 +1 @@
+

wgmaster/vba/Form_FSortenkuerzelUmbenennen.frm

@@ -0,0 +1,129 @@
+Private Sub BUmbenennen_Click()
+
+DoCmd.Hourglass True
+DoCmd.DoMenuItem acFormBar, acRecordsMenu, acSaveRecord, , acMenuVer70
+SortenKuerzelUmbenennen
+DoCmd.Hourglass False
+DoCmd.Close
+Forms!FSorten.Requery
+
+End Sub
+
+Private Sub Form_Open(Cancel As Integer)
+
+TempTabelleAnlegen
+
+Forms!FSortenkuerzelUmbenennen.RecordSource = "xTempSortenkuerzelumbenennen"
+Requery
+
+End Sub
+
+Sub TempTabelleAnlegen()
+
+Dim db1 As Database
+Dim rs1 As Recordset
+Dim rs2 As Recordset
+
+Set db1 = CurrentDb
+
+If TableExists("xTempSortenkuerzelUmbenennen") Then
+db1.Execute ("drop table xTempSortenkuerzelUmbenennen")
+End If
+db1.Execute ("Create table xTempSortenkuerzelUmbenennen (SNRAlt TEXT, BezeichnungAlt TEXT, kgprohaalt DOUBLE,typalt TEXT, SNRNeu TEXT, BezeichnungNeu TEXT, kgprohaneu DOUBLE, typneu TEXT)")
+db1.Execute ("delete * from xTempSortenkuerzelumbenennen")
+Set rs1 = db1.OpenRecordset("SELECT * FROM TSorten")
+Set rs2 = db1.OpenRecordset("xTempSortenkuerzelumbenennen")
+While Not rs1.EOF
+ rs2.AddNew
+ rs2!SNRAlt = rs1!SNR
+ rs2!SNRNeu = rs1!SNR
+ rs2!BezeichnungAlt = rs1!Bezeichnung
+ rs2!Bezeichnungneu = rs1!Bezeichnung
+ rs2!kgprohaneu = rs1!KgProHa
+ rs2!kgprohaalt = rs1!KgProHa
+ rs2!Typalt = rs1!Typ
+ rs2!Typneu = rs1!Typ
+ 
+ rs2.Update
+ rs1.MoveNext
+Wend
+rs1.Close
+rs2.Close
+
+
+End Sub
+
+
+Sub SortenKuerzelUmbenennen()
+
+Dim db1 As Database
+Dim rs1 As Recordset
+Dim rs2 As Recordset
+
+Set db1 = CurrentDb
+
+Set rs1 = db1.OpenRecordset("SELECT * from xTempSortenkuerzelUmbenennen ORDER BY SNRAlt")
+
+'1. Alle Sorten von alt auf neu mit n als Präfix
+While Not rs1.EOF
+
+ 'TAuszahlungSorten
+ db1.Execute ("UPDATE TAuszahlungSorten SET SNR='n" + rs1!SNRNeu + "' WHERE SNR='" + Format(rs1!SNRAlt) + "'")
+ 'TFlaechenbindungen
+ db1.Execute ("UPDATE TFlaechenbindungen SET SNR='n" + rs1!SNRNeu + "' WHERE SNR='" + Format(rs1!SNRAlt) + "'")
+ 'TLieferungen
+ db1.Execute ("UPDATE TLieferungen SET SNR='n" + rs1!SNRNeu + "' WHERE SNR='" + Format(rs1!SNRAlt) + "'")
+ 'TSorten
+ db1.Execute ("UPDATE TSorten SET SNR='n" + rs1!SNRNeu + "',kgproha=" + Format(rs1!kgprohaneu) + " WHERE SNR='" + Format(rs1!SNRAlt) + "'")
+ 
+ rs1.MoveNext
+Wend
+rs1.Close
+
+'2. Bei allen Sorten den Präfix n entfernen
+
+Set rs1 = db1.OpenRecordset("SELECT DISTINCT SNRNeu from xTempSortenkuerzelUmbenennen ORDER BY SNRNeu")
+db1.Execute ("DELETE * FROM TSorten")
+Set rs2 = db1.OpenRecordset("TSorten")
+
+While Not rs1.EOF
+
+ 'TAuszahlungSorten
+ db1.Execute ("UPDATE TAuszahlungSorten SET SNR='" + rs1!SNRNeu + "' WHERE SNR='n" + rs1!SNRNeu + "'")
+ 'TFlaechenbindungen
+ db1.Execute ("UPDATE TFlaechenbindungen SET SNR='" + rs1!SNRNeu + "' WHERE SNR='n" + rs1!SNRNeu + "'")
+ 'TLieferungen
+ db1.Execute ("UPDATE TLieferungen SET SNR='" + rs1!SNRNeu + "' WHERE SNR='n" + rs1!SNRNeu + "'")
+ 'TSorten
+ ' db1.Execute ("UPDATE TSorten SET SNR='" + rs1!SNRneu + "' WHERE SNR='n" + rs1!SNRneu + "'")
+ rs2.AddNew
+ rs2!SNR = rs1!SNRNeu
+ rs2!KgProHa = DFirst("kgprohaneu", "xTempSortenkuerzelUmbenennen", "SNRNeu='" + rs1!SNRNeu + "'")
+ rs2!Bezeichnung = DFirst("Bezeichnungneu", "xTempSortenkuerzelUmbenennen", "SNRNeu='" + rs1!SNRNeu + "'")
+ rs2!Typ = DFirst("typneu", "xTempSortenkuerzelUmbenennen", "SNRNeu='" + rs1!SNRNeu + "'")
+ rs2.Update
+ 
+ rs1.MoveNext
+Wend
+rs1.Close
+
+
+
+End Sub
+
+Function TableExists(table1) As Boolean
+
+Dim db1 As Database
+Set db1 = CurrentDb
+Dim x As TableDef
+
+For Each x In db1.TableDefs
+ If x.Name = table1 Then
+   TableExists = True
+   Exit Function
+ End If
+Next x
+
+   TableExists = False
+
+End Function

wgmaster/vba/Form_FTextelemente.frm

@@ -0,0 +1,36 @@
+Option Compare Database
+Option Explicit
+
+
+
+Private Sub Form_Close()
+
+If Not IsNull(TAuszahlungtext) Then SetParameter "AUSZAHLUNGTEXT", TAuszahlungtext
+If Not IsNull(TLieferscheintext) Then SetParameter "LIEFERSCHEINTEXT", TLieferscheintext
+If Not IsNull(TAnlieferungsbestätigung) Then SetParameter "ANLIEFTEXT", TAnlieferungsbestätigung
+If Not IsNull(TAuszahlungzusatz_PA) Then SetParameter "AUSZAHLUNGZUSATZTEXT_PA", TAuszahlungzusatz_PA
+If Not IsNull(TAuszahlungzusatz_BF) Then SetParameter "AUSZAHLUNGZUSATZTEXT_BF", TAuszahlungzusatz_BF
+If Not IsNull(TAbsendertext1) Then SetParameter "ABSENDERTEXT1", TAbsendertext1
+If Not IsNull(TAbsendertext2) Then SetParameter "ABSENDERTEXT2", TAbsendertext2
+
+
+End Sub
+
+Private Sub Form_Open(Cancel As Integer)
+
+If Not IsNull(GetParameter("AUSZAHLUNGTEXT")) Then TAuszahlungtext = GetParameter("AUSZAHLUNGTEXT")
+If Not IsNull(GetParameter("LIEFERSCHEINTEXT")) Then TLieferscheintext = GetParameter("LIEFERSCHEINTEXT")
+If Not IsNull(GetParameter("ANLIEFTEXT")) Then TAnlieferungsbestätigung = GetParameter("ANLIEFTEXT")
+If Not IsNull(GetParameter("AUSZAHLUNGZUSATZTEXT_BF")) Then TAuszahlungzusatz_BF = GetParameter("AUSZAHLUNGZUSATZTEXT_BF")
+If Not IsNull(GetParameter("AUSZAHLUNGZUSATZTEXT_PA")) Then TAuszahlungzusatz_PA = GetParameter("AUSZAHLUNGZUSATZTEXT_PA")
+If Not IsNull(GetParameter("ABSENDERTEXT1")) Then TAbsendertext1 = GetParameter("ABSENDERTEXT1")
+If Not IsNull(GetParameter("ABSENDERTEXT2")) Then TAbsendertext2 = GetParameter("ABSENDERTEXT2")
+
+
+End Sub
+
+
+
+
+
+

wgmaster/vba/Form_FUebernahmeChargenauswahl.frm

@@ -0,0 +1,18 @@
+
+
+Private Sub BAuswaehlen_Click()
+
+If LChargen > 0 Then
+ Forms("FÜbernahme")!TCNR = LChargen
+End If
+
+DoCmd.Close
+
+End Sub
+
+Private Sub LChargen_DblClick(Cancel As Integer)
+
+Forms("FÜbernahme")!TCNR = LChargen
+DoCmd.Close
+
+End Sub

wgmaster/vba/Form_FUmrechnung.frm

@@ -0,0 +1,19 @@
+Private Sub LGNR_Exit(Cancel As Integer)
+
+End Sub
+Private Sub Befehl48_Click()
+On Error GoTo Err_Befehl48_Click
+
+    Dim stDocName As String
+
+    stDocName = "BUmrechnung"
+    DoCmd.OpenReport stDocName, acViewPreview
+
+Exit_Befehl48_Click:
+    Exit Sub
+
+Err_Befehl48_Click:
+    MsgBox Err.Description
+    Resume Exit_Befehl48_Click
+    
+End Sub

wgmaster/vba/Form_FZweigstellen.frm

@@ -0,0 +1,3 @@
+Private Sub LGNR_Exit(Cancel As Integer)
+
+End Sub

wgmaster/vba/Form_FÜbernahmeAbschlag.frm

@@ -0,0 +1,19 @@
+Private Sub LGNR_Exit(Cancel As Integer)
+
+End Sub
+Private Sub Befehl46_Click()
+On Error GoTo Err_Befehl46_Click
+
+    Dim stDocName As String
+
+    stDocName = "BAbschlaege"
+    DoCmd.OpenReport stDocName, acViewPreview
+
+Exit_Befehl46_Click:
+    Exit Sub
+
+Err_Befehl46_Click:
+    MsgBox Err.Description
+    Resume Exit_Befehl46_Click
+    
+End Sub

wgmaster/vba/Form_MAbwertungen.frm

@@ -0,0 +1,38 @@
+
+Private Sub Babbrechen_Click()
+
+DoCmd.Close
+
+End Sub
+
+Private Sub BOk_Click()
+
+Select Case OListe
+
+Case 1:
+ DoCmd.OpenReport "BAbwertungenMGNR", acPreview, , "ZNR=" + Format(Forms!MAbwertungen!TZNR)
+Case 2:
+ DoCmd.OpenReport "BAbwertungen", acPreview, , "ZNR=" + Format(Forms!MAbwertungen!TZNR)
+Case 3:
+ DoCmd.OpenReport "BAbwertungenSorte", acPreview, , "ZNR=" + Format(Forms!MAbwertungen!TZNR)
+
+End Select
+
+End Sub
+
+
+
+
+
+Private Sub Form_Open(Cancel As Integer)
+
+TZNR = DFirst("ZNR", "TZweigstellen")
+If Month(Date) < 9 Then
+ TLesejahr = year(Date) - 1
+Else
+ TLesejahr = year(Date)
+End If
+OListe = 1
+
+End Sub
+

wgmaster/vba/Form_MAdministration.frm

@@ -0,0 +1,328 @@
+Option Compare Database
+Option Explicit
+
+Private Sub Befehl14_Click()
+
+Dim filename As String
+Dim defaultfilename As String
+Dim str1
+
+If IsNull(GetParameter("UPDATEPATH")) Then
+  SetParameter "UPDATEPATH", "A:\WGUPDATE.ACCDB"
+End If
+
+defaultfilename = GetParameter("UPDATEPATH")
+
+'defaultfilename = "D:\PROJEKT\CHRIS\WGMASTER\WGUPDATE.ACCDB"
+
+filename = InputBox("Geben Sie Bitte den Dateinamen ein: ", "Update einspielen", defaultfilename)
+
+If Not IsNull(filename) And filename <> "" Then
+
+SetParameter "UPDATEPATH", filename
+
+Dim db1 As Database
+Dim cnt1 As Container
+Dim doc1 As Document
+      
+ ' Current Database for SQL Statements
+Dim db2 As Database
+Dim rs1 As Recordset
+
+
+Set db2 = Application.DBEngine.Workspaces(0).OpenDatabase(GetDataPath())
+
+ On Error GoTo err1
+ Set db1 = Application.DBEngine.Workspaces(0).OpenDatabase(filename)
+ On Error GoTo 0
+  For Each cnt1 In db1.Containers
+   If cnt1.Name = "Forms" Then
+    For Each doc1 In cnt1.Documents
+     If MsgBox(doc1.Name + " importieren ?", vbYesNo) = vbYes Then
+      On Error Resume Next
+      'close open forms
+      If Not IsNull(Form(doc1.Name)) Then
+       DoCmd.Close acForm, doc1.Name
+      End If
+      
+      DoCmd.DeleteObject acForm, doc1.Name
+      DoCmd.TransferDatabase acImport, "Microsoft Access", filename, acForm, doc1.Name, doc1.Name
+     End If
+    Next doc1
+   End If
+   If cnt1.Name = "Reports" Then
+    For Each doc1 In cnt1.Documents
+     If MsgBox(doc1.Name + " importieren ?", vbYesNo) = vbYes Then
+      On Error Resume Next
+      DoCmd.DeleteObject acReport, doc1.Name
+      DoCmd.TransferDatabase acImport, "Microsoft Access", filename, acReport, doc1.Name, doc1.Name
+     End If
+    Next doc1
+   End If
+   
+   If cnt1.Name = "Tables" Then
+    For Each doc1 In cnt1.Documents
+     If doc1.Name = "Update_SQLStatements" Then
+      Set rs1 = db1.OpenRecordset("Update_SQLStatements")
+      While Not rs1.EOF
+       If MsgBox(rs1!Beschreibung + " ?", vbYesNo) = vbYes Then
+        db2.Execute (rs1!SQLStatement)
+       End If
+       rs1.MoveNext
+      Wend
+      rs1.Close
+     End If
+    Next doc1
+   End If
+
+   If cnt1.Name = "Modules" Then
+    For Each doc1 In cnt1.Documents
+     If MsgBox(doc1.Name + " importieren ?", vbYesNo) = vbYes Then
+      On Error Resume Next
+      DoCmd.DeleteObject acModule, doc1.Name
+      DoCmd.TransferDatabase acImport, "Microsoft Access", filename, acModule, doc1.Name, doc1.Name
+     End If
+    Next doc1
+   End If
+
+
+ Next cnt1
+
+End If
+
+Exit Sub
+
+err1:
+
+MsgBox "FEHLER: Update-Datei nicht gefunden !", vbCritical
+
+End Sub
+
+Private Sub Befehl15_Click()
+
+DoCmd.OpenForm "MImport"
+
+End Sub
+
+Private Sub Befehl16_Click()
+
+DoCmd.OpenForm "MExport"
+
+End Sub
+
+
+
+Private Sub BLogoAkt_Click()
+
+Dim datapath As String
+Dim Data As String
+
+Data = DMax("[Data]", "Mandanten", "MANR=" + Format(Forms!MMandantenauswahl!LMandanten))
+datapath = GetPathWithoutFilename(Data)
+If FileSystem.FileLen(datapath + "LOGO.BMP") > 0 Then
+ SetReportControlProperty1 "", "BLogo", acImage, "Picture", datapath + "LOGO.BMP"
+End If
+ 
+End Sub
+
+Function SetReportControlProperty1(reportname As String, ControlName As String, Controltype As Integer, PropertyName As String, PropertyValue As Variant)
+' Sets the given property of the given control in the given form to the given value
+' If Formname="" then all forms
+' If Controlname="" then all controls
+
+Dim sec1 As Section
+Dim ctl1 As Control
+Dim i As Variant
+
+If reportname = "" Or IsNull(reportname) Then
+'All Reports
+ Dim db1 As Database
+ Dim cnt1 As Container
+ Dim doc1 As Document
+
+ Set db1 = CurrentDb
+  For Each cnt1 In db1.Containers
+   If cnt1.Name = "Reports" Then
+    For Each doc1 In cnt1.Documents
+     If doc1.Name <> "BAuszahlungsvariante" Then
+        DoCmd.OpenReport doc1.Name, acViewDesign
+        
+        On Error Resume Next
+        'look into all sections
+        For i = 0 To 8
+         'If Reports(doc1.Name).Section(i).Visible = True Then
+           Reports(doc1.Name).Controls(ControlName).Properties(PropertyName) = PropertyValue
+           'Set sec1 = Reports(doc1.Name).Section(i)
+           'For Each ctl1 In sec1.Controls
+            'If ctl1.Name = ControlName Or ControlName = "" Or IsNull(ControlName) Then
+             'If Controltype = ctl1.Controltype Or Controltype = -1 Then
+              'On Error Resume Next
+              'ctl1.Properties(PropertyName) = PropertyValue
+             'End If
+            'End If
+           'Next ctl1
+         'End If
+        Next i
+        DoCmd.Save
+        DoCmd.Close
+     End If
+    Next doc1
+   End If
+ Next cnt1
+
+Else
+ DoCmd.OpenReport reportname, acViewDesign
+ For i = 0 To 8
+  Set sec1 = Reports(reportname).Section(i)
+  For Each ctl1 In sec1.Controls
+   If ctl1.Name = ControlName Or ControlName = "" Or IsNull(ControlName) Then
+    On Error Resume Next
+    ctl1.Properties(PropertyName) = PropertyValue
+   End If
+  Next ctl1
+ Next i
+ DoCmd.Save
+ DoCmd.Close
+End If
+
+End Function
+
+Private Sub BOk_Click()
+
+If LWaagentyp <> "L246" Then
+ DoCmd.OpenForm "FÜbernahme", acDesign
+ Forms!FÜbernahme!XComm.Settings = TSettings
+ Forms!FÜbernahme!XComm.CommPort = LPort
+ Forms!FÜbernahme!XCommSteuerung.CommPort = LPortSteuerung
+ DoCmd.Save
+ DoCmd.Close
+End If
+
+SetParameter "WAAGENTYP", LWaagentyp
+SetParameter "STEUERUNGTYP", LSteuerungtyp
+SetParameter "WAAGEPORT", LPort
+SetParameter "STEUERUNGPORT", LPortSteuerung
+SetParameter "WAAGEPORTSETTINGS", TSettings
+
+
+SetParameter "WAAGENMONITORLIMIT", TWaagenmonitorLimit
+
+If OWaagenmonitor Then
+ SetParameter "WAAGENMONITOR", "1"
+Else
+ SetParameter "WAAGENMONITOR", "0"
+End If
+
+
+DoCmd.Close
+
+End Sub
+
+Private Sub Form_Close()
+
+SetParameter "WAAGENTYP", LWaagentyp
+
+If LSteuerungtyp = "PARALLEL" Then
+ SetParameter "STEUERUNGPORT", LLPT
+End If
+
+If LSteuerungtyp = "SERIELL" Then
+ SetParameter "STEUERUNGPORT", LPortSteuerung
+End If
+
+If LSteuerungtyp = "EXTERN" Then
+ SetParameter "STEUERUNGEXTERN", TExtern
+End If
+
+End Sub
+
+Private Sub Form_Open(Cancel As Integer)
+
+
+'DoCmd.OpenForm "FÜbernahme", acDesign
+
+'TSettings = Forms!FÜbernahme!XComm.Settings
+'LPort = Forms!FÜbernahme!XComm.CommPort
+'LPortSteuerung = Forms!FÜbernahme!XCommSteuerung.CommPort
+TSettings = GetParameter("WAAGEPORTSETTINGS")
+LPort = GetParameter("WAAGEPORT")
+LPortSteuerung = GetParameter("STEUERUNGPORT")
+
+'DoCmd.Save
+'DoCmd.Close
+
+LWaagentyp = GetParameter("WAAGENTYP")
+LSteuerungtyp = GetParameter("STEUERUNGTYP")
+
+Dim host As String
+Dim tcpport As Long
+
+If IsNull(GetParameter("WAAGEHOST")) Then
+ SetParameter "WAAGEHOST", "10.0.0.80"
+ SetParameter "WAAGETCPPORT", "1234"
+End If
+
+host = GetParameter("WAAGEHOST")
+tcpport = GetParameter("WAAGETCPPORT")
+
+
+
+If LSteuerungtyp = "SERIELL" Then
+ LPortSteuerung.Visible = True
+ XPortSteuerung.Visible = True
+ LPortSteuerung = GetParameter("STEUERUNGPORT")
+Else
+ LPortSteuerung.Visible = False
+ XPortSteuerung.Visible = False
+End If
+
+If LSteuerungtyp = "PARALLEL" Then
+ LLPT.Visible = True
+ XLPT.Visible = True
+ LLPT = GetParameter("STEUERUNGPORT")
+Else
+ LLPT.Visible = False
+ XLPT.Visible = False
+End If
+
+If LSteuerungtyp = "EXTERN" Then
+ TExtern.Visible = True
+ TExtern = GetParameter("STEUERUNGEXTERN")
+Else
+ TExtern.Visible = False
+End If
+
+TWaagenmonitorLimit = GetParameter("WAAGENMONITORLIMIT")
+If GetParameter("WAAGENMONITOR") = "1" Then
+ OWaagenmonitor = True
+Else
+ OWaagenmonitor = False
+End If
+
+End Sub
+
+Private Sub LSteuerungtyp_Click()
+
+If LSteuerungtyp = "SERIELL" Then
+ LPortSteuerung.Visible = True
+ XPortSteuerung.Visible = True
+Else
+ LPortSteuerung.Visible = False
+ XPortSteuerung.Visible = False
+End If
+
+If LSteuerungtyp = "PARALLEL" Then
+ LLPT.Visible = True
+ XLPT.Visible = True
+Else
+ LLPT.Visible = False
+ XLPT.Visible = False
+End If
+
+If LSteuerungtyp = "EXTERN" Then
+ TExtern.Visible = True
+Else
+ TExtern.Visible = False
+End If
+
+End Sub

wgmaster/vba/Form_MAdministrationCopy.frm

@@ -0,0 +1,328 @@
+Option Compare Database
+Option Explicit
+
+Private Sub Befehl14_Click()
+
+Dim filename As String
+Dim defaultfilename As String
+Dim str1
+
+If IsNull(GetParameter("UPDATEPATH")) Then
+  SetParameter "UPDATEPATH", "A:\WGUPDATE.ACCDB"
+End If
+
+defaultfilename = GetParameter("UPDATEPATH")
+
+'defaultfilename = "D:\PROJEKT\CHRIS\WGMASTER\WGUPDATE.ACCDB"
+
+filename = InputBox("Geben Sie Bitte den Dateinamen ein: ", "Update einspielen", defaultfilename)
+
+If Not IsNull(filename) And filename <> "" Then
+
+SetParameter "UPDATEPATH", filename
+
+Dim db1 As Database
+Dim cnt1 As Container
+Dim doc1 As Document
+      
+ ' Current Database for SQL Statements
+Dim db2 As Database
+Dim rs1 As Recordset
+
+
+Set db2 = Application.DBEngine.Workspaces(0).OpenDatabase(GetDataPath())
+
+ On Error GoTo err1
+ Set db1 = Application.DBEngine.Workspaces(0).OpenDatabase(filename)
+ On Error GoTo 0
+  For Each cnt1 In db1.Containers
+   If cnt1.Name = "Forms" Then
+    For Each doc1 In cnt1.Documents
+     If MsgBox(doc1.Name + " importieren ?", vbYesNo) = vbYes Then
+      On Error Resume Next
+      'close open forms
+      If Not IsNull(Form(doc1.Name)) Then
+       DoCmd.Close acForm, doc1.Name
+      End If
+      
+      DoCmd.DeleteObject acForm, doc1.Name
+      DoCmd.TransferDatabase acImport, "Microsoft Access", filename, acForm, doc1.Name, doc1.Name
+     End If
+    Next doc1
+   End If
+   If cnt1.Name = "Reports" Then
+    For Each doc1 In cnt1.Documents
+     If MsgBox(doc1.Name + " importieren ?", vbYesNo) = vbYes Then
+      On Error Resume Next
+      DoCmd.DeleteObject acReport, doc1.Name
+      DoCmd.TransferDatabase acImport, "Microsoft Access", filename, acReport, doc1.Name, doc1.Name
+     End If
+    Next doc1
+   End If
+   
+   If cnt1.Name = "Tables" Then
+    For Each doc1 In cnt1.Documents
+     If doc1.Name = "Update_SQLStatements" Then
+      Set rs1 = db1.OpenRecordset("Update_SQLStatements")
+      While Not rs1.EOF
+       If MsgBox(rs1!Beschreibung + " ?", vbYesNo) = vbYes Then
+        db2.Execute (rs1!SQLStatement)
+       End If
+       rs1.MoveNext
+      Wend
+      rs1.Close
+     End If
+    Next doc1
+   End If
+
+   If cnt1.Name = "Modules" Then
+    For Each doc1 In cnt1.Documents
+     If MsgBox(doc1.Name + " importieren ?", vbYesNo) = vbYes Then
+      On Error Resume Next
+      DoCmd.DeleteObject acModule, doc1.Name
+      DoCmd.TransferDatabase acImport, "Microsoft Access", filename, acModule, doc1.Name, doc1.Name
+     End If
+    Next doc1
+   End If
+
+
+ Next cnt1
+
+End If
+
+Exit Sub
+
+err1:
+
+MsgBox "FEHLER: Update-Datei nicht gefunden !", vbCritical
+
+End Sub
+
+Private Sub Befehl15_Click()
+
+DoCmd.OpenForm "MImport"
+
+End Sub
+
+Private Sub Befehl16_Click()
+
+DoCmd.OpenForm "MExport"
+
+End Sub
+
+
+
+Private Sub BLogoAkt_Click()
+
+Dim datapath As String
+Dim Data As String
+
+Data = DMax("[Data]", "Mandanten", "MANR=" + Format(Forms!MMandantenauswahl!LMandanten))
+datapath = GetPathWithoutFilename(Data)
+If FileSystem.FileLen(datapath + "LOGO.BMP") > 0 Then
+ SetReportControlProperty1 "", "BLogo", acImage, "Picture", datapath + "LOGO.BMP"
+End If
+ 
+End Sub
+
+Function SetReportControlProperty1(reportname As String, ControlName As String, Controltype As Integer, PropertyName As String, PropertyValue As Variant)
+' Sets the given property of the given control in the given form to the given value
+' If Formname="" then all forms
+' If Controlname="" then all controls
+
+Dim sec1 As Section
+Dim ctl1 As Control
+Dim i As Variant
+
+If reportname = "" Or IsNull(reportname) Then
+'All Reports
+ Dim db1 As Database
+ Dim cnt1 As Container
+ Dim doc1 As Document
+
+ Set db1 = CurrentDb
+  For Each cnt1 In db1.Containers
+   If cnt1.Name = "Reports" Then
+    For Each doc1 In cnt1.Documents
+     If doc1.Name <> "BAuszahlungsvariante" Then
+        DoCmd.OpenReport doc1.Name, acViewDesign
+        
+        On Error Resume Next
+        'look into all sections
+        For i = 0 To 8
+         'If Reports(doc1.Name).Section(i).Visible = True Then
+           Reports(doc1.Name).Controls(ControlName).Properties(PropertyName) = PropertyValue
+           'Set sec1 = Reports(doc1.Name).Section(i)
+           'For Each ctl1 In sec1.Controls
+            'If ctl1.Name = ControlName Or ControlName = "" Or IsNull(ControlName) Then
+             'If Controltype = ctl1.Controltype Or Controltype = -1 Then
+              'On Error Resume Next
+              'ctl1.Properties(PropertyName) = PropertyValue
+             'End If
+            'End If
+           'Next ctl1
+         'End If
+        Next i
+        DoCmd.Save
+        DoCmd.Close
+     End If
+    Next doc1
+   End If
+ Next cnt1
+
+Else
+ DoCmd.OpenReport reportname, acViewDesign
+ For i = 0 To 8
+  Set sec1 = Reports(reportname).Section(i)
+  For Each ctl1 In sec1.Controls
+   If ctl1.Name = ControlName Or ControlName = "" Or IsNull(ControlName) Then
+    On Error Resume Next
+    ctl1.Properties(PropertyName) = PropertyValue
+   End If
+  Next ctl1
+ Next i
+ DoCmd.Save
+ DoCmd.Close
+End If
+
+End Function
+
+Private Sub BOk_Click()
+
+If LWaagentyp <> "L246" Then
+ DoCmd.OpenForm "FÜbernahme", acDesign
+ Forms!FÜbernahme!XComm.Settings = TSettings
+ Forms!FÜbernahme!XComm.CommPort = LPort
+ Forms!FÜbernahme!XCommSteuerung.CommPort = LPortSteuerung
+ DoCmd.Save
+ DoCmd.Close
+End If
+
+SetParameter "WAAGENTYP", LWaagentyp
+SetParameter "STEUERUNGTYP", LSteuerungtyp
+SetParameter "WAAGEPORT", LPort
+SetParameter "STEUERUNGPORT", LPortSteuerung
+SetParameter "WAAGEPORTSETTINGS", TSettings
+
+
+SetParameter "WAAGENMONITORLIMIT", TWaagenmonitorLimit
+
+If OWaagenmonitor Then
+ SetParameter "WAAGENMONITOR", "1"
+Else
+ SetParameter "WAAGENMONITOR", "0"
+End If
+
+
+DoCmd.Close
+
+End Sub
+
+Private Sub Form_Close()
+
+SetParameter "WAAGENTYP", LWaagentyp
+
+If LSteuerungtyp = "PARALLEL" Then
+ SetParameter "STEUERUNGPORT", LLPT
+End If
+
+If LSteuerungtyp = "SERIELL" Then
+ SetParameter "STEUERUNGPORT", LPortSteuerung
+End If
+
+If LSteuerungtyp = "EXTERN" Then
+ SetParameter "STEUERUNGEXTERN", TExtern
+End If
+
+End Sub
+
+Private Sub Form_Open(Cancel As Integer)
+
+
+'DoCmd.OpenForm "FÜbernahme", acDesign
+
+'TSettings = Forms!FÜbernahme!XComm.Settings
+'LPort = Forms!FÜbernahme!XComm.CommPort
+'LPortSteuerung = Forms!FÜbernahme!XCommSteuerung.CommPort
+TSettings = GetParameter("WAAGEPORTSETTINGS")
+LPort = GetParameter("WAAGEPORT")
+LPortSteuerung = GetParameter("STEUERUNGPORT")
+
+'DoCmd.Save
+'DoCmd.Close
+
+LWaagentyp = GetParameter("WAAGENTYP")
+LSteuerungtyp = GetParameter("STEUERUNGTYP")
+
+Dim host As String
+Dim tcpport As Long
+
+If IsNull(GetParameter("WAAGEHOST")) Then
+ SetParameter "WAAGEHOST", "10.0.0.80"
+ SetParameter "WAAGETCPPORT", "1234"
+End If
+
+host = GetParameter("WAAGEHOST")
+tcpport = GetParameter("WAAGETCPPORT")
+
+
+
+If LSteuerungtyp = "SERIELL" Then
+ LPortSteuerung.Visible = True
+ XPortSteuerung.Visible = True
+ LPortSteuerung = GetParameter("STEUERUNGPORT")
+Else
+ LPortSteuerung.Visible = False
+ XPortSteuerung.Visible = False
+End If
+
+If LSteuerungtyp = "PARALLEL" Then
+ LLPT.Visible = True
+ XLPT.Visible = True
+ LLPT = GetParameter("STEUERUNGPORT")
+Else
+ LLPT.Visible = False
+ XLPT.Visible = False
+End If
+
+If LSteuerungtyp = "EXTERN" Then
+ TExtern.Visible = True
+ TExtern = GetParameter("STEUERUNGEXTERN")
+Else
+ TExtern.Visible = False
+End If
+
+TWaagenmonitorLimit = GetParameter("WAAGENMONITORLIMIT")
+If GetParameter("WAAGENMONITOR") = "1" Then
+ OWaagenmonitor = True
+Else
+ OWaagenmonitor = False
+End If
+
+End Sub
+
+Private Sub LSteuerungtyp_Click()
+
+If LSteuerungtyp = "SERIELL" Then
+ LPortSteuerung.Visible = True
+ XPortSteuerung.Visible = True
+Else
+ LPortSteuerung.Visible = False
+ XPortSteuerung.Visible = False
+End If
+
+If LSteuerungtyp = "PARALLEL" Then
+ LLPT.Visible = True
+ XLPT.Visible = True
+Else
+ LLPT.Visible = False
+ XLPT.Visible = False
+End If
+
+If LSteuerungtyp = "EXTERN" Then
+ TExtern.Visible = True
+Else
+ TExtern.Visible = False
+End If
+
+End Sub

wgmaster/vba/Form_MAdministrationCopy2.frm

@@ -0,0 +1,326 @@
+Option Compare Database
+Option Explicit
+
+Private Sub Befehl14_Click()
+
+Dim filename As String
+Dim defaultfilename As String
+Dim str1
+
+If IsNull(GetParameter("UPDATEPATH")) Then
+  SetParameter "UPDATEPATH", "A:\WGUPDATE.ACCDB"
+End If
+
+defaultfilename = GetParameter("UPDATEPATH")
+
+'defaultfilename = "D:\PROJEKT\CHRIS\WGMASTER\WGUPDATE.ACCDB"
+
+filename = InputBox("Geben Sie Bitte den Dateinamen ein: ", "Update einspielen", defaultfilename)
+
+If Not IsNull(filename) And filename <> "" Then
+
+SetParameter "UPDATEPATH", filename
+
+Dim db1 As Database
+Dim cnt1 As Container
+Dim doc1 As Document
+      
+ ' Current Database for SQL Statements
+Dim db2 As Database
+Dim rs1 As Recordset
+
+
+Set db2 = Application.DBEngine.Workspaces(0).OpenDatabase(GetDataPath())
+
+ On Error GoTo err1
+ Set db1 = Application.DBEngine.Workspaces(0).OpenDatabase(filename)
+ On Error GoTo 0
+  For Each cnt1 In db1.Containers
+   If cnt1.Name = "Forms" Then
+    For Each doc1 In cnt1.Documents
+     If MsgBox(doc1.Name + " importieren ?", vbYesNo) = vbYes Then
+      On Error Resume Next
+      'close open forms
+      If Not IsNull(Form(doc1.Name)) Then
+       DoCmd.Close acForm, doc1.Name
+      End If
+      
+      DoCmd.DeleteObject acForm, doc1.Name
+      DoCmd.TransferDatabase acImport, "Microsoft Access", filename, acForm, doc1.Name, doc1.Name
+     End If
+    Next doc1
+   End If
+   If cnt1.Name = "Reports" Then
+    For Each doc1 In cnt1.Documents
+     If MsgBox(doc1.Name + " importieren ?", vbYesNo) = vbYes Then
+      On Error Resume Next
+      DoCmd.DeleteObject acReport, doc1.Name
+      DoCmd.TransferDatabase acImport, "Microsoft Access", filename, acReport, doc1.Name, doc1.Name
+     End If
+    Next doc1
+   End If
+   
+   If cnt1.Name = "Tables" Then
+    For Each doc1 In cnt1.Documents
+     If doc1.Name = "Update_SQLStatements" Then
+      Set rs1 = db1.OpenRecordset("Update_SQLStatements")
+      While Not rs1.EOF
+       If MsgBox(rs1!Beschreibung + " ?", vbYesNo) = vbYes Then
+        db2.Execute (rs1!SQLStatement)
+       End If
+       rs1.MoveNext
+      Wend
+      rs1.Close
+     End If
+    Next doc1
+   End If
+
+   If cnt1.Name = "Modules" Then
+    For Each doc1 In cnt1.Documents
+     If MsgBox(doc1.Name + " importieren ?", vbYesNo) = vbYes Then
+      On Error Resume Next
+      DoCmd.DeleteObject acModule, doc1.Name
+      DoCmd.TransferDatabase acImport, "Microsoft Access", filename, acModule, doc1.Name, doc1.Name
+     End If
+    Next doc1
+   End If
+
+
+ Next cnt1
+
+End If
+
+Exit Sub
+
+err1:
+
+MsgBox "FEHLER: Update-Datei nicht gefunden !", vbCritical
+
+End Sub
+
+Private Sub Befehl15_Click()
+
+DoCmd.OpenForm "MImport"
+
+End Sub
+
+Private Sub Befehl16_Click()
+
+DoCmd.OpenForm "MExport"
+
+End Sub
+
+
+
+Private Sub BLogoAkt_Click()
+
+Dim datapath As String
+Dim Data As String
+
+Data = DMax("[Data]", "Mandanten", "MANR=" + Format(Forms!MMandantenauswahl!LMandanten))
+datapath = GetPathWithoutFilename(Data)
+If FileSystem.FileLen(datapath + "LOGO.BMP") > 0 Then
+ SetReportControlProperty1 "", "BLogo", acImage, "Picture", datapath + "LOGO.BMP"
+End If
+ 
+End Sub
+
+Function SetReportControlProperty1(reportname As String, ControlName As String, Controltype As Integer, PropertyName As String, PropertyValue As Variant)
+' Sets the given property of the given control in the given form to the given value
+' If Formname="" then all forms
+' If Controlname="" then all controls
+
+Dim sec1 As Section
+Dim ctl1 As Control
+Dim i As Variant
+
+If reportname = "" Or IsNull(reportname) Then
+'All Reports
+ Dim db1 As Database
+ Dim cnt1 As Container
+ Dim doc1 As Document
+
+ Set db1 = CurrentDb
+  For Each cnt1 In db1.Containers
+   If cnt1.Name = "Reports" Then
+    For Each doc1 In cnt1.Documents
+     DoCmd.OpenReport doc1.Name, acViewDesign
+     
+     On Error Resume Next
+     'look into all sections
+     For i = 0 To 8
+      'If Reports(doc1.Name).Section(i).Visible = True Then
+        Reports(doc1.Name).Controls(ControlName).Properties(PropertyName) = PropertyValue
+        'Set sec1 = Reports(doc1.Name).Section(i)
+        'For Each ctl1 In sec1.Controls
+         'If ctl1.Name = ControlName Or ControlName = "" Or IsNull(ControlName) Then
+          'If Controltype = ctl1.Controltype Or Controltype = -1 Then
+           'On Error Resume Next
+           'ctl1.Properties(PropertyName) = PropertyValue
+          'End If
+         'End If
+        'Next ctl1
+      'End If
+     Next i
+     DoCmd.Save
+     DoCmd.Close
+    Next doc1
+   End If
+ Next cnt1
+
+Else
+ DoCmd.OpenReport reportname, acViewDesign
+ For i = 0 To 8
+  Set sec1 = Reports(reportname).Section(i)
+  For Each ctl1 In sec1.Controls
+   If ctl1.Name = ControlName Or ControlName = "" Or IsNull(ControlName) Then
+    On Error Resume Next
+    ctl1.Properties(PropertyName) = PropertyValue
+   End If
+  Next ctl1
+ Next i
+ DoCmd.Save
+ DoCmd.Close
+End If
+
+End Function
+
+Private Sub BOk_Click()
+
+If LWaagentyp <> "L246" Then
+ DoCmd.OpenForm "FÜbernahme", acDesign
+ Forms!FÜbernahme!XComm.Settings = TSettings
+ Forms!FÜbernahme!XComm.CommPort = LPort
+ Forms!FÜbernahme!XCommSteuerung.CommPort = LPortSteuerung
+ DoCmd.Save
+ DoCmd.Close
+End If
+
+SetParameter "WAAGENTYP", LWaagentyp
+SetParameter "STEUERUNGTYP", LSteuerungtyp
+SetParameter "WAAGEPORT", LPort
+SetParameter "STEUERUNGPORT", LPortSteuerung
+SetParameter "WAAGEPORTSETTINGS", TSettings
+
+
+SetParameter "WAAGENMONITORLIMIT", TWaagenmonitorLimit
+
+If OWaagenmonitor Then
+ SetParameter "WAAGENMONITOR", "1"
+Else
+ SetParameter "WAAGENMONITOR", "0"
+End If
+
+
+DoCmd.Close
+
+End Sub
+
+Private Sub Form_Close()
+
+SetParameter "WAAGENTYP", LWaagentyp
+
+If LSteuerungtyp = "PARALLEL" Then
+ SetParameter "STEUERUNGPORT", LLPT
+End If
+
+If LSteuerungtyp = "SERIELL" Then
+ SetParameter "STEUERUNGPORT", LPortSteuerung
+End If
+
+If LSteuerungtyp = "EXTERN" Then
+ SetParameter "STEUERUNGEXTERN", TExtern
+End If
+
+End Sub
+
+Private Sub Form_Open(Cancel As Integer)
+
+
+'DoCmd.OpenForm "FÜbernahme", acDesign
+
+'TSettings = Forms!FÜbernahme!XComm.Settings
+'LPort = Forms!FÜbernahme!XComm.CommPort
+'LPortSteuerung = Forms!FÜbernahme!XCommSteuerung.CommPort
+TSettings = GetParameter("WAAGEPORTSETTINGS")
+LPort = GetParameter("WAAGEPORT")
+LPortSteuerung = GetParameter("STEUERUNGPORT")
+
+'DoCmd.Save
+'DoCmd.Close
+
+LWaagentyp = GetParameter("WAAGENTYP")
+LSteuerungtyp = GetParameter("STEUERUNGTYP")
+
+Dim host As String
+Dim tcpport As Long
+
+If IsNull(GetParameter("WAAGEHOST")) Then
+ SetParameter "WAAGEHOST", "10.0.0.80"
+ SetParameter "WAAGETCPPORT", "1234"
+End If
+
+host = GetParameter("WAAGEHOST")
+tcpport = GetParameter("WAAGETCPPORT")
+
+
+
+If LSteuerungtyp = "SERIELL" Then
+ LPortSteuerung.Visible = True
+ XPortSteuerung.Visible = True
+ LPortSteuerung = GetParameter("STEUERUNGPORT")
+Else
+ LPortSteuerung.Visible = False
+ XPortSteuerung.Visible = False
+End If
+
+If LSteuerungtyp = "PARALLEL" Then
+ LLPT.Visible = True
+ XLPT.Visible = True
+ LLPT = GetParameter("STEUERUNGPORT")
+Else
+ LLPT.Visible = False
+ XLPT.Visible = False
+End If
+
+If LSteuerungtyp = "EXTERN" Then
+ TExtern.Visible = True
+ TExtern = GetParameter("STEUERUNGEXTERN")
+Else
+ TExtern.Visible = False
+End If
+
+TWaagenmonitorLimit = GetParameter("WAAGENMONITORLIMIT")
+If GetParameter("WAAGENMONITOR") = "1" Then
+ OWaagenmonitor = True
+Else
+ OWaagenmonitor = False
+End If
+
+End Sub
+
+Private Sub LSteuerungtyp_Click()
+
+If LSteuerungtyp = "SERIELL" Then
+ LPortSteuerung.Visible = True
+ XPortSteuerung.Visible = True
+Else
+ LPortSteuerung.Visible = False
+ XPortSteuerung.Visible = False
+End If
+
+If LSteuerungtyp = "PARALLEL" Then
+ LLPT.Visible = True
+ XLPT.Visible = True
+Else
+ LLPT.Visible = False
+ XLPT.Visible = False
+End If
+
+If LSteuerungtyp = "EXTERN" Then
+ TExtern.Visible = True
+Else
+ TExtern.Visible = False
+End If
+
+End Sub

wgmaster/vba/Form_MAnlieferung.frm

@@ -0,0 +1,113 @@
+
+Private Sub Babbrechen_Click()
+
+DoCmd.Close
+
+End Sub
+
+Private Sub BOk_Click()
+
+
+Dim v1, b1
+Dim filter1
+
+If Not IsNull(TVon) Then
+ GebundenBerechnen year(TVon), OSortenattributeBeiFlächenbindungOptional, OGebunden
+Else
+ If Not IsNull(TBis) Then
+  GebundenBerechnen year(TBis), OSortenattributeBeiFlächenbindungOptional, OGebunden
+ End If
+End If
+
+SetParameter "ANLIEFTEXT", TFusstext.Value
+
+If IsNull(TVon1) Then
+  v1 = 0
+Else
+  v1 = TVon1
+End If
+ 
+If IsNull(TBis1) Then
+  b1 = 999999
+Else
+  b1 = TBis1
+End If
+
+
+filter1 = "Storniert=False AND "
+
+If IsNull(TZNR) Or TZNR = "" Then
+Else
+ filter1 = filter1 + "[ZNR]=" + Format(TZNR) + " AND "
+End If
+
+
+
+If IsNull(TVon) Or TVon = "" Then
+Else
+ filter1 = filter1 + "Datum>=Datevalue('" + Format(TVon) + "') AND "
+End If
+
+If IsNull(TBis) Or TBis = "" Then
+Else
+ filter1 = filter1 + "Datum<=Datevalue('" + Format(TBis) + "') AND "
+End If
+
+Select Case OListe
+
+Case 1:
+ filter1 = filter1 + "MGNR>=" + Format(v1) + " AND MGNR<=" + Format(b1)
+ 'MsgBox (filter1)
+ DoCmd.OpenReport "BAnlieferungsbestaetigungMGNR", acPreview, , filter1
+Case 2:
+ filter1 = filter1 + "PLZ>='" + Format(v1) + "' AND PLZ<='" + Format(b1) + "'"
+ 'MsgBox (filter1)
+ DoCmd.OpenReport "BAnlieferungsbestaetigung", acPreview, , filter1
+
+End Select
+
+DoCmd.Maximize
+
+
+End Sub
+
+Private Sub BTagWeiter_Click()
+
+TVon = DateValue("01.09." + Format(year(TVon) + 1))
+TBis = DateValue("01.11." + Format(year(TBis) + 1))
+
+End Sub
+
+Private Sub BTagZurueck_Click()
+
+TVon = DateValue("01.09." + Format(year(TVon) - 1))
+TBis = DateValue("01.11." + Format(year(TBis) - 1))
+
+End Sub
+
+
+
+Private Sub Form_Open(Cancel As Integer)
+
+OListe = 1
+TVon = DateValue("01.09." + Format(year(Date)))
+TBis = DateValue("01.11." + Format(year(Date)))
+'TZNR = DFirst("ZNR", "TZweigstellen")
+TFusstext = GetParameter("ANLIEFTEXT")
+OSortenattributeBeiFlächenbindungOptional = False
+
+End Sub
+
+
+
+
+Private Sub TFusstext_Exit(Cancel As Integer)
+
+If IsNull(TFusstext.Value) Then
+ SetParameter "ANLIEFTEXT", " "
+Else
+ SetParameter "ANLIEFTEXT", TFusstext.Value
+End If
+
+End Sub
+

wgmaster/vba/Form_MAnlieferungenJahresvergleich.frm

@@ -0,0 +1,137 @@
+Dim filter1 As String
+
+Private Sub Babbrechen_Click()
+
+DoCmd.Close
+
+End Sub
+
+Private Sub BDetailliert_Click()
+
+If IsNull(TVon) Then
+ MsgBox ("Bitte geben Sie im Feld 'Von' das Startjahr der Auswertung ein")
+ Exit Sub
+End If
+ 
+If IsNull(TBis) Then
+ MsgBox ("Bitte geben Sie im Feld 'Bis' das Endjahr der Auswertung ein")
+ Exit Sub
+End If
+
+SetFilter
+
+DoCmd.OpenReport "BAnlieferungenJahresvergleichDetail", acViewPreview, , filter1
+
+DoCmd.Maximize
+
+
+End Sub
+
+Private Sub BOk_Click()
+
+If IsNull(TVon) Then
+ MsgBox ("Bitte geben Sie im Feld 'Von' das Startjahr der Auswertung ein")
+ Exit Sub
+End If
+ 
+If IsNull(TBis) Then
+ MsgBox ("Bitte geben Sie im Feld 'Bis' das Endjahr der Auswertung ein")
+ Exit Sub
+End If
+
+SetFilter
+'MsgBox (filter1)
+
+DoCmd.OpenReport "BAnlieferungenJahresVergleichDetail", acViewPreview, , filter1
+
+DoCmd.Maximize
+
+End Sub
+
+Sub SetFilter()
+
+
+filter1 = "Storniert=False AND "
+
+If IsNull(TZNR) Or TZNR = "" Then
+Else
+ filter1 = filter1 + "[ZNR]=" + Format(TZNR) + " AND "
+End If
+
+If IsNull(TVon) Or TVon = "" Then
+Else
+ filter1 = filter1 + "Year(Datum)>=" + Format(TVon) + " AND "
+End If
+
+If IsNull(TBis) Or TBis = "" Then
+Else
+ filter1 = filter1 + "Year(Datum)<=" + Format(TBis) + " AND "
+End If
+
+If IsNull(TSNR) Or TSNR = "" Then
+Else
+ filter1 = filter1 + "SNR='" + Format(TSNR) + "' AND "
+End If
+
+If IsNull(TSANR) Or TSANR = "" Then
+Else
+ filter1 = filter1 + "SANR='" + Format(TSANR) + "' AND "
+End If
+
+
+If OAktiveMitglieder = True Then
+ filter1 = filter1 + "[Aktives Mitglied]=True AND "
+End If
+
+
+If IsNull(TVon1) Then
+  v1 = 0
+Else
+  v1 = TVon1
+End If
+ 
+If IsNull(TBis1) Then
+  b1 = 999999
+Else
+  b1 = TBis1
+End If
+
+
+Select Case OListe
+Case 1:
+
+ filter1 = filter1 + "MGNR>=" + Format(v1) + " AND MGNR<=" + Format(b1)
+ 'MsgBox (filter1)
+Case 2:
+ filter1 = filter1 + "PLZ>='" + Format(v1) + "' AND PLZ<='" + Format(b1) + "'"
+ 'MsgBox (filter1)
+End Select
+
+
+
+
+End Sub
+
+Private Sub Form_Open(Cancel As Integer)
+
+OListe = 1
+TVon = year(Date) - 5
+TBis = year(Date)
+OSortenattributeBeiFlächenbindungOptional = False
+OAktiveMitglieder = True
+
+End Sub
+
+
+
+
+Private Sub TFusstext_Exit(Cancel As Integer)
+
+If IsNull(TFusstext.Value) Then
+ SetParameter "ANLIEFTEXT", " "
+Else
+ SetParameter "ANLIEFTEXT", TFusstext.Value
+End If
+
+End Sub
+

wgmaster/vba/Form_MAuswertung.frm

@@ -0,0 +1,37 @@
+Private Sub BBKIListe_Click()
+
+DoCmd.OpenForm "MExportBKIListe"
+
+End Sub
+
+Private Sub Befehl17_Click()
+
+DoCmd.OpenForm "MAuswertungMitglieder"
+
+
+End Sub
+
+Private Sub Befehl18_Click()
+
+DoCmd.OpenForm "MLeseauswertung"
+
+End Sub
+
+Private Sub Befehl23_Click()
+
+DoCmd.OpenForm "MAbwertungen"
+
+End Sub
+
+Private Sub Befehl24_Click()
+
+'DoCmd.OpenReport "BÜberlieferungen", acViewPreview
+DoCmd.OpenForm "MUnterlieferungen"
+
+End Sub
+
+Private Sub BJahresvergleich_Click()
+
+DoCmd.OpenForm "MAnlieferungenJahresvergleich"
+
+End Sub

wgmaster/vba/Form_MAuswertungMitglieder.frm

@@ -0,0 +1,129 @@
+Private Sub Befehl19_Click()
+
+DoCmd.OpenReport "BFlaechenbindungen", acViewPreview
+
+End Sub
+
+Private Sub BJahrMinus_Click()
+
+If Not IsNull(TJahr) Then
+  TJahr = TJahr - 1
+  RefreshAll
+End If
+
+End Sub
+
+Private Sub BJAhrPlus_Click()
+
+If Not IsNull(TJahr) Then
+  TJahr = TJahr + 1
+  RefreshAll
+End If
+
+End Sub
+
+Private Sub BKonsistenzprüfung_Click()
+
+DoCmd.OpenForm ("MMitgliederKonsistenz")
+
+End Sub
+
+Private Sub BVolllieferanten_Click()
+
+DoCmd.OpenReport "BMitgliederlisteVolllieferanten", acViewPreview
+
+End Sub
+
+Private Sub Form_Open(Cancel As Integer)
+
+TJahr = year(Date)
+RefreshAll
+
+End Sub
+
+
+
+Private Sub RefreshAll()
+
+filter1 = GetFilter
+filter2 = " AND [Aktives Mitglied]=True AND ( Year(Eintrittsdatum)<=" + Format(Forms!MAuswertungMitglieder!TJahr) + " OR Isnull(Eintrittsdatum)) " + " AND (Year(Austrittsdatum)>=" + Format(Forms!MAuswertungMitglieder!TJahr) + " OR Isnull(Austrittsdatum))"
+
+'TAnzahlAktiveMitglieder
+TAnzahlAktiveMitglieder = DCount("MGNR", "TMitglieder", "MGNR>=0 " + filter1 + filter2)
+
+'TGA1
+
+TGA1 = DSum("[Geschäftsanteile1]", "TMitglieder", "MGNR>=0 " + filter1 + filter2)
+
+
+'TAnzahlFlaechengebundeneMitglieder
+
+TAnzahlFlaechengebundeneMitglieder = DCount("TMitglieder.MGNR", "TMitglieder", "MGNR IN (SELECT DISTINCT TMitglieder.MGNR FROM TMitglieder INNER JOIN TFlaechenbindungen ON TMitglieder.MGNR = TFlaechenbindungen.MGNR WHERE TFlaechenbindungen.Von<= " + Format(Forms!MAuswertungMitglieder!TJahr) + " AND (TFlaechenbindungen.Bis>=" + Format(Forms!MAuswertungMitglieder!TJahr) + " OR isnull(TFlaechenbindungen.Bis))) " + filter1)
+
+
+'TVollmitglieder
+
+TVollmitglieder = DCount("MGNR", "TMitglieder", "[Volllieferant]=True" + filter1 + filter2)
+
+
+'TGebundeneFlaecheGesamt
+
+'TGebundeneFlaecheGesamt = DSum("Flaeche", "TFlaechenbindungen", "MGNR IN (SELECT DISTINCT TMitglieder.MGNR FROM TMitglieder INNER JOIN TFlaechenbindungen ON TMitglieder.MGNR = TFlaechenbindungen.MGNR WHERE TFlaechenbindungen.Von<=" + Format(Forms!MAuswertungMitglieder!TJahr) + " AND (TFlaechenbindungen.Bis>=" + Format(Forms!MAuswertungMitglieder!TJahr) + " OR isnull(TFlaechenbindungen.Bis)) " + filter1 + " ) ")
+TGebundeneFlaecheGesamt = GetGebundeneFlächeGesamt(filter1)
+
+
+'LFlaechenbindungen
+
+Dim query1 As String
+
+
+query1 = "SELECT DISTINCT TSorten.Bezeichnung, Sum(TFlaechenbindungen.Flaeche) AS [Gesamtflaeche] FROM (TMitglieder INNER JOIN TFlaechenbindungen ON TMitglieder.MGNR = TFlaechenbindungen.MGNR) INNER JOIN TSorten ON TFlaechenbindungen.SNR = TSorten.SNR WHERE TFlaechenbindungen.Von<=" + Format(Forms!MAuswertungMitglieder!TJahr) + " AND (TFlaechenbindungen.Bis >= " + Format(Forms!MAuswertungMitglieder!TJahr) + " OR isnull(TFlaechenbindungen.Bis)) " + filter1 + " GROUP BY TSorten.Bezeichnung;"
+
+LFlaechenbindungen.RowSource = query1
+LFlaechenbindungen.Requery
+
+
+
+End Sub
+
+Function GetGebundeneFlächeGesamt(filter) As Double
+
+Dim db1 As Database
+Dim rs1 As Recordset
+Dim year As String
+Dim fb As Double
+Set db1 = CurrentDb
+year = Format(Forms!MAuswertungMitglieder!TJahr)
+
+fb = 0
+Set rs1 = db1.OpenRecordset("SELECT * FROM TMitglieder INNER JOIN TFlaechenbindungen ON TMitglieder.MGNR=TFlaechenbindungen.MGNR WHERE [Aktives Mitglied]=True AND (Von<=" + year + " or Von=Null) AND (Bis>=" + year + " or Bis=Null) " + filter)
+While Not rs1.EOF
+  If Not IsNull(rs1("Flaeche")) Then
+    fb = fb + rs1("Flaeche")
+  End If
+rs1.MoveNext
+Wend
+rs1.Close
+
+GetGebundeneFlächeGesamt = fb
+
+End Function
+
+Function GetFilter() As String
+
+If IsNull(TZNR) Or TZNR = "" Or TZNR <= 0 Then
+ GetFilter = ""
+Else
+ GetFilter = " AND ZNR=" + Format(TZNR)
+End If
+
+
+End Function
+
+Private Sub TZNR_Change()
+
+RefreshAll
+
+
+
+End Sub

wgmaster/vba/Form_MAuszahlung.frm

@@ -0,0 +1,29 @@
+Private Sub BBereinigungLieferungen_Click()
+
+DoCmd.OpenForm "MLieferscheinBereinigung"
+
+End Sub
+
+Private Sub Befehl17_Click()
+
+DoCmd.OpenForm "MAuszahlungAuswahl"
+
+End Sub
+
+Private Sub Befehl18_Click()
+
+DoCmd.OpenForm "MAnlieferung"
+
+End Sub
+
+Private Sub Befehl23_Click()
+
+DoCmd.OpenForm "MStammblatt"
+
+End Sub
+
+Private Sub Befehl24_Click()
+
+DoCmd.OpenForm "MRundschreiben"
+
+End Sub

wgmaster/vba/Form_MAuszahlungAuswahl.frm

@@ -0,0 +1,515 @@
+
+Dim lastAZNR
+
+Private Sub BBearbeiten_Click()
+
+If LAuszahlungen >= 0 Then
+ lastAZNR = LAuszahlungen
+ DoCmd.OpenForm "FAuszahlung", acNormal, , "AZNR=" + Format(LAuszahlungen)
+End If
+
+End Sub
+
+
+Private Sub BJahrWeiter_Click()
+
+If Not IsNull(TLesejahr) Then
+ TLesejahr = TLesejahr + 1
+ RefreshAll
+End If
+
+End Sub
+
+Private Sub BJahrZurueck_Click()
+
+If Not IsNull(TLesejahr) Then
+ TLesejahr = TLesejahr - 1
+ RefreshAll
+End If
+
+End Sub
+
+Private Sub BKopieren_Click()
+
+Dim aznr2 As Long
+
+If Not IsNull(LAuszahlungen) And LAuszahlungen > 0 Then
+ If MsgBox("Wollen Sie diese Variante für eine neue Variante kopieren ?", vbYesNo) = vbYes Then
+   aznr2 = NeueAuszahlung
+   AuszahlungKopieren LAuszahlungen, aznr2
+   lastAZNR = aznr2
+   RefreshAll
+ End If
+Else
+ MsgBox ("Bitte wählen sie die zu kopierende Auszahlung !")
+End If
+
+End Sub
+
+
+Private Sub BLöschen_Click()
+
+Dim aznr2
+
+If Not IsNull(LAuszahlungen) And LAuszahlungen > 0 Then
+ If MsgBox("Wollen Sie diese Auszahlung wirklich löschen ?", vbYesNo) = vbYes Then
+  AuszahlungLöschen (LAuszahlungen)
+ End If
+Else
+ MsgBox ("Bitte wählen sie die zu löschende Auszahlung !")
+End If
+RefreshAll
+
+End Sub
+
+Private Sub BNeu_Click()
+
+Dim aznr1 As Long
+
+aznr1 = NeueAuszahlung
+lastAZNR = aznr1
+RefreshAll
+
+End Sub
+
+Private Sub Form_Activate()
+
+RefreshAll
+
+End Sub
+
+Private Sub Form_Load()
+ 
+
+If Month(Date) < 9 Then
+ TLesejahr = year(Date) - 1
+Else
+ TLesejahr = year(Date)
+End If
+
+TZahlung = 0
+
+lastAZNR = -1
+
+RefreshAll
+
+
+
+End Sub
+
+Private Sub LAuszahlungen_DblClick(Cancel As Integer)
+
+lastAZNR = LAuszahlungen
+
+DoCmd.OpenForm "FAuszahlung", acNormal, , "AZNR=" + Format(LAuszahlungen)
+
+
+End Sub
+
+Private Sub TLesejahr_Exit(Cancel As Integer)
+
+RefreshAll
+
+End Sub
+
+Function GetFilter() As String
+
+Dim filter1
+
+filter1 = " Lesejahr =" + Format(TLesejahr)
+
+If Not IsNull(TZahlung) And TZahlung > 0 Then
+  filter1 = filter1 + " AND TeilzahlungNr =" + TZahlung
+End If
+
+GetFilter = filter1
+
+End Function
+
+
+Sub RefreshAll()
+
+Dim filter1
+Dim query1
+
+query1 = "SELECT TAuszahlung.AZNR, TAuszahlung.Lesejahr, IIf([TeilzahlungNr]=7,'Probevariante',IIf([TeilzahlungNr]=6,'Endauszahlung',IIf([TeilzahlungNr]=5,Getparameter('FREIERAUSZAHLUNGSTITEL'),Format([TeilzahlungNr])+' .Teilzahlung'))) AS Zahlung, TAuszahlung.Titel, TAuszahlung.Beschreibung, TAuszahlung.Datum FROM TAuszahlung "
+
+filter1 = GetFilter
+query1 = query1 + " WHERE " + filter1 + GetOrder
+'MsgBox (query1)
+LAuszahlungen.RowSource = query1
+LAuszahlungen.Requery
+
+LAuszahlungen.SetFocus
+
+If lastAZNR = -1 And LAuszahlungen.ListCount > 0 Then
+'MsgBox (LAuszahlungen.ItemData(1))
+ LAuszahlungen = LAuszahlungen.ItemData(1)
+End If
+
+If lastAZNR >= 0 Then
+ LAuszahlungen = lastAZNR
+End If
+
+
+End Sub
+
+
+
+Private Sub TZahlung_Change()
+
+RefreshAll
+
+End Sub
+
+
+Function NeueAuszahlung() As Long
+
+Dim str1 As String
+Dim db1 As Database
+Dim rs1 As Recordset
+Dim SNR(0 To 255) As String
+Dim SANR(0 To 255) As String
+Dim Oechsle(0 To 255) As Long
+Dim sortencount As Integer, oechslecount As Integer, i, j
+Dim aznr1 As Long
+ 
+'Requery
+NeueAuszahlung = 0
+'DoCmd.GoToRecord , , acLast
+'ErgebnisfelderLoeschen
+
+str1 = InputBox("Geben Sie bitte einen Titel für die neue Variante ein: ")
+lj = InputBox("Geben Sie bitte das Lesejahr ein: ", , TLesejahr)
+
+If str1 <> "" And Not IsNull(str1) And Not IsNull(lj) Then
+
+ DoCmd.Hourglass True
+ Set db1 = CurrentDb
+ Set rs1 = db1.OpenRecordset("TAuszahlung")
+ rs1.AddNew
+ rs1!Titel = str1
+ rs1!TeilzahlungNr = 7
+ rs1!Lesejahr = CLng(lj)
+ rs1!Datum = Date
+ rs1!Rebelzuschlag = 0
+ rs1!Grundbetrag = 0
+ rs1!GBZS = 0
+ rs1!Ausgabefaktor = 1
+ aznr1 = rs1!AZNR
+ rs1.Update
+ rs1.Close
+
+ 'TTitel = str1
+ 'TLesejahr = lj
+ 
+ Dim omin, omax
+ 
+ omin = DMin("Oechsle", "TLieferungen", "Year(Datum)=" + Format(lj) + " AND Oechsle>0")
+ omax = DMax("Oechsle", "TLieferungen", "Year(Datum)=" + Format(lj) + " AND Oechsle<150")
+ 
+ 'DoCmd.DoMenuItem acFormBar, acRecordsMenu, acSaveRecord, , acMenuVer70
+
+ Set db1 = CurrentDb
+ 
+ ' Sortenkürzel sicherheitshalber nochmals bereinigen
+ Set rs1 = db1.OpenRecordset("SELECT SNR FROM TLieferungen WHERE Year(Datum)=" + Format(lj))
+ While Not rs1.EOF
+  If IsNull(rs1!SNR) Or rs1!SNR = "" Then
+  Else
+   If UCase(rs1("SNR")) <> rs1("SNR") Then
+    rs1.Edit
+    rs1("SNR") = UCase(rs1("SNR"))
+    rs1.Update
+   End If
+  End If
+  rs1.MoveNext
+ Wend
+ rs1.Close
+ 
+ 
+ ' Sorten einlesen
+ sortencount = 0
+ 
+ Set rs1 = db1.OpenRecordset("SELECT DISTINCT SNR FROM TLieferungen WHERE Year(Datum)=" + Format(lj) + " ORDER BY SNR")
+'Set rs1 = db1.OpenRecordset("SELECT * FROM TSorten")
+ 
+ While Not rs1.EOF
+  If IsNull(rs1!SNR) Or rs1!SNR = "" Then
+  Else
+   SNR(sortencount) = rs1!SNR
+   SANR(sortencount) = ""
+   sortencount = sortencount + 1
+  End If
+  rs1.MoveNext
+ Wend
+ rs1.Close
+
+' Oechsle einlesen
+ If omin > Val(GetParameter("ABWERTUNGOECHSLE")) Then
+   omin = GetParameter("ABWERTUNGOECHSLE")
+ End If
+ oechslecount = 0
+ For i = omin - 5 To omax + 5
+  Oechsle(oechslecount) = i
+  oechslecount = oechslecount + 1
+ Next i
+ 
+ 
+ Set rs1 = db1.OpenRecordset("SELECT * FROM TAuszahlungSorten")
+ For i = 0 To sortencount - 1
+  For j = 0 To oechslecount - 1
+   rs1.AddNew
+   rs1!AZNR = aznr1
+   rs1!Oechsle = Oechsle(j)
+   rs1!SNR = SNR(i)
+   rs1!Betrag = 0
+   rs1!gebunden = False
+   rs1.Update
+   rs1.AddNew
+   rs1!AZNR = aznr1
+   rs1!Oechsle = Oechsle(j)
+   rs1!SNR = SNR(i)
+   rs1!Betrag = 0
+   rs1!gebunden = True
+   rs1.Update
+  Next j, i
+ rs1.Close
+ 
+ 'Create Qualitätsstufentable for QSNR=0 / "Wein" only
+ Set rs1 = db1.OpenRecordset("SELECT * FROM TAuszahlungSortenQualitätsstufe")
+ For i = 0 To sortencount - 1
+   rs1.AddNew
+   rs1!AZNR = aznr1
+   rs1!SNR = SNR(i)
+   rs1!SANR = SANR(i)
+   rs1!QSNR = 0
+   rs1!Betrag = 0
+   rs1.Update
+   
+  Next i
+ rs1.Close
+ 
+ 'Erweiterung der Liste um vorhandene Sortenattribute
+ ' Sorten einlesen
+ sortencount = 0
+ Set rs1 = db1.OpenRecordset("SELECT DISTINCT SNR,SANR FROM TLieferungen WHERE Year(Datum)=" + Format(lj) + " AND SANR<>NULL AND SANR<>''")
+ While Not rs1.EOF
+  If IsNull(rs1!SNR) Or rs1!SNR = "" Then
+  Else
+   SNR(sortencount) = rs1!SNR
+   SANR(sortencount) = rs1!SANR
+   sortencount = sortencount + 1
+  End If
+  rs1.MoveNext
+ Wend
+ rs1.Close
+ 
+ Set rs1 = db1.OpenRecordset("SELECT * FROM TAuszahlungSorten")
+ For i = 0 To sortencount - 1
+  For j = 0 To oechslecount - 1
+   rs1.AddNew
+   rs1!AZNR = aznr1
+   rs1!Oechsle = Oechsle(j)
+   rs1!SNR = SNR(i)
+   rs1!SANR = SANR(i)
+   rs1!Betrag = 0
+   rs1!gebunden = False
+   rs1.Update
+   rs1.AddNew
+   rs1!AZNR = aznr1
+   rs1!Oechsle = Oechsle(j)
+   rs1!SNR = SNR(i)
+   rs1!SANR = SANR(i)
+   rs1!Betrag = 0
+   rs1!gebunden = True
+   rs1.Update
+  Next j, i
+ rs1.Close
+ 
+ 'Create Qualitätsstufentable for QSNR=0 / "Wein" only
+ Set rs1 = db1.OpenRecordset("SELECT * FROM TAuszahlungSortenQualitätsstufe")
+ For i = 0 To sortencount - 1
+   rs1.AddNew
+   rs1!AZNR = aznr1
+   rs1!SNR = SNR(i)
+   rs1!SANR = SANR(i)
+   rs1!QSNR = 0
+   rs1!Betrag = 0
+   rs1.Update
+   
+  Next i
+ rs1.Close
+ 
+ 
+ 'FUnter1.Requery
+ DoCmd.Hourglass False
+ NeueAuszahlung = aznr1
+End If
+
+
+End Function
+
+
+Function AuszahlungKopierenAlt(aznr1 As Long) As Long
+
+Dim aznr2 As Long
+Dim db1 As Database
+Dim rs1 As Recordset
+Dim rs2 As Recordset
+Dim rs3 As Recordset
+Dim rs4 As Recordset
+Dim str1 As String
+Dim lj As String
+Dim Lesejahr1 As Long
+
+ 
+ str1 = InputBox("Geben Sie bitte einen Titel für die neue Variante ein: ")
+  
+ If str1 <> "" And Not IsNull(str1) Then
+    
+    Lesejahr1 = InputBox("Lesejahr: ", "Lesejahr", TLesejahr)
+ 
+    Set db1 = CurrentDb
+    Set rs1 = db1.OpenRecordset("SELECT * FROM TAuszahlungSorten WHERE AZNR=" + Format(aznr1))
+    Set rs4 = db1.OpenRecordset("SELECT * FROM TAuszahlung WHERE AZNR=" + Format(aznr1))
+    Set rs2 = db1.OpenRecordset("TAuszahlungSorten")
+    Set rs3 = db1.OpenRecordset("TAuszahlung")
+    rs3.AddNew
+    rs3!Titel = str1
+    rs3!Lesejahr = Lesejahr1
+    rs3!Datum = rs4!Datum
+    rs3!Grundbetrag = rs4!Grundbetrag
+    rs3!GBZS = rs4!GBZS
+    rs3!Ausgabefaktor = 1
+    rs3!TeilzahlungNr = 7
+    rs3!Endauszahlung = 0
+    rs3!RIZS = rs4!RIZS
+    rs3!GEZS = rs4!GEZS
+    rs3!GLZS = rs4!GLZS
+    rs3!WEZS = rs4!WEZS
+    rs3!REZS = rs4!REZS
+    rs3!Abschlägeberücksichtigen = rs4!Abschlägeberücksichtigen
+    rs3!GebundenBerücksichtigen = rs4!GebundenBerücksichtigen
+    rs3!AufschlagVolllieferanten = rs4!AufschlagVolllieferanten
+    rs3.Update
+    rs3.Close
+    aznr2 = DMax("AZNR", "TAuszahlung")
+    
+    While Not rs1.EOF
+     rs2.AddNew
+     rs2!SNR = rs1!SNR
+     rs2!Oechsle = rs1!Oechsle
+     rs2!Betrag = rs1!Betrag
+     rs2!AZNR = aznr2
+     rs2.Update
+     rs1.MoveNext
+    Wend
+    rs1.Close
+    rs2.Close
+    
+
+
+    'Requery
+    'DoCmd.GoToRecord , , acLast
+    AuszahlungKopierenAlt = aznr2
+ 
+ End If
+
+
+
+End Function
+
+
+Sub AuszahlungKopieren(from_aznr As Long, to_aznr As Long)
+' Kopiert die Grundwerte und Sortentabellen soweit vorhanden
+
+Dim aznr2 As Long
+Dim db1 As Database
+Dim rs_from As Recordset
+Dim rs_from_sorten As Recordset
+Dim rs_to As Recordset
+Dim rs_to_sorten As Recordset
+Dim KeineGebundenen As Boolean
+Dim GBZS1 As Double
+
+Dim SNR1 As Double
+Dim Oechlse1 As Double
+Dim Betrag1 As Double
+
+Set db1 = CurrentDb
+Set rs_to = db1.OpenRecordset("SELECT * FROM TAuszahlung WHERE AZNR=" + Format(to_aznr))
+Set rs_from = db1.OpenRecordset("SELECT * FROM TAuszahlung WHERE AZNR=" + Format(from_aznr))
+
+rs_to.Edit
+rs_to!Grundbetrag = rs_from!Grundbetrag
+rs_to!GBZS = rs_from!GBZS
+GBZS1 = rs_from!GBZS
+rs_to!Ausgabefaktor = rs_from!Ausgabefaktor
+rs_to!TeilzahlungNr = 7
+rs_to!Endauszahlung = 0
+rs_to!RIZS = rs_from!RIZS
+rs_to!GEZS = rs_from!GEZS
+rs_to!GLZS = rs_from!GLZS
+rs_to!WEZS = rs_from!WEZS
+rs_to!REZS = rs_from!REZS
+rs_to!Abschlägeberücksichtigen = rs_from!Abschlägeberücksichtigen
+rs_to!GebundenBerücksichtigen = rs_from!GebundenBerücksichtigen
+rs_to!AufschlagVolllieferanten = rs_from!AufschlagVolllieferanten
+rs_to.Update
+rs_to.Close
+rs_from.Close
+
+'enthält Kopie Felder mit Gebunden ?
+If DCount("SNR", "TAuszahlungSorten", "AZNR=" + Format(from_aznr) + " AND gebunden=True") > 0 Then
+ KeineGebundenen = False
+Else
+ KeineGebundenen = True
+End If
+
+
+'Sortentabelleninhalte kopieren soweit verfügbar
+Set rs_from_sorten = db1.OpenRecordset("SELECT * FROM TAuszahlungSorten WHERE AZNR=" + Format(from_aznr))
+
+While Not rs_from_sorten.EOF
+
+  If IsNull(rs_from_sorten!SANR) Then
+    Set rs_to_sorten = db1.OpenRecordset("SELECT * FROM TAuszahlungSorten WHERE AZNR=" + Format(to_aznr) + " AND SNR='" + rs_from_sorten!SNR + "' AND Oechsle=" + Format(rs_from_sorten!Oechsle) + " AND gebunden=" + IIf(rs_from_sorten!gebunden, "true", "false") + " AND SANR=Null")
+  Else
+    Set rs_to_sorten = db1.OpenRecordset("SELECT * FROM TAuszahlungSorten WHERE AZNR=" + Format(to_aznr) + " AND SNR='" + rs_from_sorten!SNR + "' AND Oechsle=" + Format(rs_from_sorten!Oechsle) + " AND gebunden=" + IIf(rs_from_sorten!gebunden, "true", "false") + " AND SANR='" + Format(rs_from_sorten!SANR) + "'")
+  End If
+
+    If Not rs_to_sorten.EOF Then
+     rs_to_sorten.Edit
+     rs_to_sorten!Betrag = rs_from_sorten!Betrag
+     rs_to_sorten.Update
+     rs_to_sorten.Close
+    End If
+    
+    If KeineGebundenen = True Then
+     Set rs_to_sorten = db1.OpenRecordset("SELECT * FROM TAuszahlungSorten WHERE AZNR=" + Format(to_aznr) + " AND SNR='" + rs_from_sorten!SNR + "' AND Oechsle=" + Format(rs_from_sorten!Oechsle) + " AND gebunden=True")
+     If Not rs_to_sorten.EOF Then
+      rs_to_sorten.Edit
+      rs_to_sorten!Betrag = rs_from_sorten!Betrag '+ GBZS1
+      rs_to_sorten!gebunden = True
+      rs_to_sorten.Update
+      rs_to_sorten.Close
+     End If
+    End If
+
+ rs_from_sorten.MoveNext
+Wend
+
+End Sub
+
+
+
+Sub AuszahlungLöschen(aznr1 As Long)
+
+Dim db1 As Database
+
+    Set db1 = CurrentDb
+    db1.Execute ("DELETE * FROM TAuszahlungSorten WHERE AZNR=" + Format(aznr1))
+    db1.Execute ("DELETE * FROM TAuszahlung WHERE AZNR=" + Format(aznr1))
+
+End Sub

wgmaster/vba/Form_MChargenAuswahl.frm

@@ -0,0 +1,251 @@
+
+Dim lastCNR
+
+Private Sub BAusPlanung_Click()
+
+Dim date1
+
+date1 = InputBox("Geben Sie bitte das Datum ein, für welches Chargen erstellt werden sollen:", , Date)
+
+If IsDate(date1) Then
+ ChargenErstellenAusPlanung (date1)
+ RefreshAll
+End If
+
+End Sub
+
+Private Sub BBearbeiten_Click()
+
+If LChargen >= 0 Then
+ lastCNR = LChargen
+ DoCmd.OpenForm "FChargen", acNormal, , "CNR=" + Format(LChargen)
+End If
+
+End Sub
+
+Private Sub BBefuellungBeenden_Click()
+
+If LChargen >= 0 Then
+ lastCNR = LChargen
+ ChargeBefuellungBeenden (LChargen)
+ RefreshAll
+End If
+
+End Sub
+
+Private Sub BBefuellungStarten_Click()
+
+If LChargen >= 0 Then
+ lastCNR = LChargen
+ ChargeBefuellungStarten (LChargen)
+ RefreshAll
+End If
+
+End Sub
+
+Private Sub BDrucken_Click()
+
+DoCmd.OpenForm "MChargenListe"
+
+End Sub
+
+Private Sub BJahrWeiter_Click()
+
+If Not IsNull(TLesejahr) Then
+ TLesejahr = TLesejahr + 1
+ RefreshAll
+End If
+
+End Sub
+
+Private Sub BJahrZurueck_Click()
+
+If Not IsNull(TLesejahr) Then
+ TLesejahr = TLesejahr - 1
+ RefreshAll
+End If
+
+End Sub
+
+Private Sub BLoeschen_Click()
+
+If LChargen > 0 Then
+  If DCount("LINR", "TLieferungen", "CNR=" + Format(LChargen)) > 0 Then
+   MsgBox "Die ausgewählte Charge kann nicht gelöscht werden, da bereits Lieferungen zugeordnet sind!", vbCritical
+   Exit Sub
+  End If
+  If DCount("CNR_Parent", "TChargenHierarchie", "CNR_Parent=" + Format(LChargen)) > 0 Then
+   MsgBox "Die ausgewählte Charge kann nicht gelöscht werden, da aus dieser Charge andere Chargen erstellt worden sind!", vbCritical
+   Exit Sub
+  End If
+  If MsgBox("Wollen Sie die ausgewählte Charge wirklich löschen?", vbYesNo) = vbYes Then
+   Dim db1 As Database
+   Set db1 = CurrentDb
+   db1.Execute ("DELETE FROM TChargen WHERE CNR=" + Format(LChargen))
+   RefreshAll
+  End If
+End If
+
+End Sub
+
+Private Sub BNeu_Click()
+
+Dim CNR1 As Long
+
+CNR1 = NeueCharge(TLesejahr)
+DoCmd.OpenForm "FChargen", acNormal, , "CNR=" + Format(CNR1)
+
+End Sub
+
+Private Sub BUmfuellen_Click()
+
+DoCmd.OpenForm "FChargeUmfuellen"
+
+End Sub
+
+Private Sub Form_Activate()
+
+RefreshAll
+
+End Sub
+
+Private Sub Form_Load()
+ 
+
+If Month(Date) < 9 Then
+ TLesejahr = year(Date) - 1
+Else
+ TLesejahr = year(Date)
+End If
+
+TSortierung = "BefuellungsBeginn,Chargennummer"
+
+lastCNR = -1
+
+ODetailLieferungen = False
+
+RefreshAll
+
+
+
+End Sub
+
+Private Sub LChargen_DblClick(Cancel As Integer)
+
+lastCNR = LChargen
+
+DoCmd.OpenForm "FChargen", acNormal, , "CNR=" + Format(LChargen)
+
+
+End Sub
+
+Private Sub TBSNR_Change()
+
+RefreshAll
+
+End Sub
+
+Private Sub TBSNR_Click()
+
+RefreshAll
+
+End Sub
+
+Private Sub TCSNR_Change()
+
+RefreshAll
+
+End Sub
+
+Private Sub TLesejahr_Exit(Cancel As Integer)
+
+RefreshAll
+
+End Sub
+
+Function GetFilter() As String
+
+Dim filter1
+
+filter1 = "Jahrgang=" + Format(TLesejahr)
+
+If Not IsNull(TZNR) Then
+  filter1 = filter1 + " AND TChargen.ZNR=" + TZNR
+End If
+
+If Not IsNull(TCSNR) Then
+  filter1 = filter1 + " AND TChargen.CSNR=" + TCSNR
+End If
+
+If Not IsNull(TBSNR) Then
+  filter1 = filter1 + " AND TBehaelter.BSNR=" + TBSNR
+End If
+
+GetFilter = filter1
+
+End Function
+
+Function GetOrder() As String
+
+If Not IsNull(TSortierung) Then
+ GetOrder = " ORDER BY " + TSortierung
+Else
+ GetOrder = ""
+End If
+
+End Function
+
+
+Sub RefreshAll()
+
+Dim filter1
+Dim query1
+
+'query1 = "SELECT TLieferungen.CNR, TLieferungen.Lieferscheinnummer AS Lieferscheinnr, TLieferungen.Datum, Format(TLieferungen.Uhrzeit,'HH:MM') as Zeit, TMitglieder.MGNR, [Nachname]+' '+IIf(IsNull([Vorname]),'',[Vorname]) AS Mitglied, TSorten.Bezeichnung AS Sorte, TLieferungen.Gewicht, TLieferungen.Oechsle, IIf(Storniert=True,'STORNIERT',Left(TLieferungen.Anmerkung,20)) AS Info FROM TSorten INNER JOIN (TMitglieder INNER JOIN TLieferungen ON TMitglieder.MGNR = TLieferungen.MGNR) ON TSorten.SNR = TLieferungen.SNR"
+query1 = "SELECT TChargen.CNR, TChargen.Chargennummer as ChNr, TChargen.Befuellungsbeginn as BefStart, TChargen.Befuellungsende as BefEnde, TChargen.BehaelterEntleertAm as Entleerg, TChargenStatus.ChargenStatus as Status, TChargen.SNR, TChargen.SANR, TQualitaetsstufen.Bezeichnung as Qualitaet, TChargen.Menge,TBehaelter.Kurzbezeichnung as Behaelter, TZweigstellen.Name as Zweigstelle FROM ((TZweigstellen RIGHT JOIN (TChargen LEFT JOIN TChargenStatus ON TChargen.CSNR = TChargenStatus.CSNR) ON TZweigstellen.ZNR = TChargen.ZNR) LEFT JOIN TBehaelter ON TChargen.BNR = TBehaelter.BNR) LEFT JOIN TQualitaetsstufen ON TChargen.QSNRVon = TQualitaetsstufen.QSNR"
+filter1 = GetFilter
+query1 = query1 + " WHERE " + filter1 + GetOrder
+'MsgBox (query1)
+LChargen.RowSource = query1
+LChargen.Requery
+
+LChargen.SetFocus
+
+If lastCNR = -1 And LChargen.ListCount > 0 Then
+'MsgBox (LChargen.ItemData(1))
+ LChargen = LChargen.ItemData(1)
+End If
+
+If lastCNR >= 0 Then
+ LChargen = lastCNR
+End If
+
+
+End Sub
+
+Private Sub TSortierung_Change()
+
+RefreshAll
+
+End Sub
+
+Private Sub TZNR_Change()
+
+RefreshAll
+
+End Sub
+Private Sub Befehl88_Click()
+On Error GoTo Err_Befehl88_Click
+
+
+    DoCmd.DoMenuItem acFormBar, acEditMenu, 8, , acMenuVer70
+    DoCmd.PrintOut acSelection
+
+Exit_Befehl88_Click:
+    Exit Sub
+
+Err_Befehl88_Click:
+    MsgBox Err.Description
+    Resume Exit_Befehl88_Click
+    
+End Sub

wgmaster/vba/Form_MChargenListe.frm

@@ -0,0 +1,263 @@
+
+
+Private Sub BOk_Click()
+
+Dim filter1 As String
+
+filter1 = GetFilter
+   
+DoCmd.OpenReport "BChargenListe", acDesign
+If ODetailLieferungen Then
+ Reports("BChargenListe").Section(0).Visible = True
+Else
+ Reports("BChargenListe").Section(0).Visible = False
+End If
+DoCmd.Save
+DoCmd.Close
+   
+   
+DoCmd.OpenReport "BChargenListe", acPreview, , filter1
+
+End Sub
+
+Private Sub BTagWeiter_Click()
+
+TVon = TVon + 1
+TBis = TBis + 1
+RefreshAll
+
+End Sub
+
+Private Sub BTagZurueck_Click()
+
+TVon = TVon - 1
+TBis = TBis - 1
+RefreshAll
+
+End Sub
+
+Private Sub Form_Activate()
+
+RefreshAll
+
+End Sub
+
+Private Sub Form_Open(Cancel As Integer)
+
+TVon = Date
+TBis = Date
+'TZNR = DFirst("ZNR", "TZweigstellen")
+ODetailLieferungen = False
+
+End Sub
+
+
+Private Sub OListe_Click()
+
+RefreshAll
+
+End Sub
+
+Private Sub Kombinationsfeld85_Click()
+RefreshAll
+
+End Sub
+
+Private Sub Kombinationsfeld85_Exit(Cancel As Integer)
+
+RefreshAll
+
+End Sub
+
+Private Sub TBis_Exit(Cancel As Integer)
+
+RefreshAll
+
+End Sub
+
+Private Sub TBNR_Click()
+
+RefreshAll
+
+End Sub
+
+Private Sub TBNR_Exit(Cancel As Integer)
+RefreshAll
+
+End Sub
+
+Private Sub TBSNR_Click()
+
+RefreshAll
+
+End Sub
+
+Private Sub TBSNR_Exit(Cancel As Integer)
+
+RefreshAll
+
+End Sub
+
+Private Sub TCSNR_Click()
+
+RefreshAll
+
+End Sub
+
+Private Sub TCSNR_Exit(Cancel As Integer)
+
+RefreshAll
+
+End Sub
+
+Private Sub TSANR_Click()
+RefreshAll
+
+End Sub
+
+Private Sub TSANR_Exit(Cancel As Integer)
+RefreshAll
+
+End Sub
+
+Private Sub TSNR_Click()
+RefreshAll
+
+End Sub
+
+Private Sub TSNR_Exit(Cancel As Integer)
+
+RefreshAll
+
+End Sub
+
+Private Sub TVon_Exit(Cancel As Integer)
+
+RefreshAll
+
+End Sub
+
+
+Function GetFilter()
+
+Dim filter1 As String
+Dim hk As String
+
+If IsNull(TZNR) Then
+ filter1 = " TChargen.CNR>0 "
+Else
+ filter1 = " TChargen.ZNR=" + Format(Forms!MChargenListe!TZNR)
+End If
+
+filter1 = filter1 + " AND [Befuellungsbeginn]>=Datevalue('" + Format([TVon], "dd.mm.yyyy") + "') AND [Befuellungsbeginn]<=Datevalue('" + Format([TBis], "dd.mm.yyyy") + "')"
+
+If Not IsNull(TCSNR) And TCSNR > 0 Then
+ filter1 = filter1 + " AND TChargen.CSNR=" + Format(TCSNR)
+End If
+
+If Not IsNull(TBNR) And TBNR > 0 Then
+ filter1 = filter1 + " AND TChargen.BNR=" + Format(TBNR)
+End If
+
+If Not IsNull(TBSNR) And TBSNR > 0 Then
+ filter1 = filter1 + " AND TBehaelter.BSNR=" + Format(TBSNR)
+End If
+
+If Not IsNull(TSNR) And TSNR <> "" Then
+ filter1 = filter1 + " AND TChargen.SNR='" + Format(TSNR) + "'"
+End If
+
+If Not IsNull(TSANR) And TSANR <> "" Then
+ filter1 = filter1 + " AND TChargen.SANR='" + Format(TSANR) + "'"
+End If
+
+'MsgBox (filter1)
+
+ GetFilter = filter1
+
+
+End Function
+
+Sub RefreshAll()
+
+
+Dim where2, where3
+
+
+'If TZNR.ListIndex >= 0 Then
+'where2 = " AND [TLieferungen].[ZNR]=[Formulare]![MLeseauswertung].[TZNR] "
+'Else
+'where2 = ""
+
+
+'CalculateSums (where2)
+RefreshBeschreibung
+
+End Sub
+
+
+Sub RefreshBeschreibung()
+
+Dim Beschreibung As String
+
+
+If Not IsNull(TVon) And Not IsNull(TBis) Then
+ If TVon = TBis Then
+  Beschreibung = Beschreibung + Format(TVon, "dd.mm.yyyy") + ", "
+ Else
+  Beschreibung = Beschreibung + Format(TVon, "dd.mm.yyyy") + "-" + Format(TBis, "dd.mm.yyyy") + ", "
+ End If
+Else
+    If Not IsNull(TVon) Then
+     Beschreibung = Beschreibung + "ab " + Format(TVon, "dd.mm.yyyy") + ", "
+    End If
+    If Not IsNull(TBis) Then
+     Beschreibung = Beschreibung + "bis " + Format(TBis, "dd.mm.yyyy") + ", "
+    End If
+ 
+End If
+
+If Not IsNull(TZNR) And TZNR > 0 Then
+ Beschreibung = Beschreibung + "Zweigstelle=" + DFirst("Name", "TZweigstellen", "ZNR=" + Format(TZNR)) + ", "
+End If
+
+If Not IsNull(TCSNR) And TCSNR > 0 Then
+ Beschreibung = Beschreibung + " Status = " + DFirst("ChargenStatus", "TChargenStatus", "CSNR=" + Format(TCSNR)) + ", "
+End If
+
+If Not IsNull(TBNR) And TBNR > 0 Then
+ Beschreibung = Beschreibung + " Behälter = " + DFirst("Kurzbezeichnung", "TBehaelter", "BNR=" + Format(TBNR)) + ", "
+End If
+
+If Not IsNull(TBSNR) And TBSNR > 0 Then
+ Beschreibung = Beschreibung + " Behälterstandort = " + DFirst("Standort", "TBehaelterStandorte", "BSNR=" + Format(TBSNR)) + ", "
+End If
+
+If Not IsNull(TSNR) And TSNR <> "" Then
+ Beschreibung = Beschreibung + " Sorte = " + DFirst("Bezeichnung", "TSorten", "SNR='" + Format(TSNR) + "'") + ", "
+End If
+
+If Not IsNull(TSANR) And TSANR <> "" Then
+ Beschreibung = Beschreibung + " Sortenattribut = " + DFirst("Attribut", "TSortenattribute", "SaNR='" + Format(TSANR) + "'") + ", "
+End If
+
+
+Beschreibung = Left(Beschreibung, Len(Beschreibung) - 2)
+
+TBeschreibung = Beschreibung
+
+End Sub
+
+
+Private Sub TZNR_Click()
+
+RefreshAll
+
+End Sub
+
+Private Sub TZNR_Exit(Cancel As Integer)
+
+RefreshAll
+
+End Sub
+

wgmaster/vba/Form_MExport.frm

@@ -0,0 +1,310 @@
+
+Private Sub Babbrechen_Click()
+
+DoCmd.Close
+
+End Sub
+
+Private Sub BOk_Click()
+
+If OMitglieder = True Or OLieferungen = True Then
+
+    If Not IsNull(TZNR) And TZNR <> "" Then
+
+        DoCmd.Hourglass True
+        ExportAll TExportFile, TZNR, TLesejahr
+        DoCmd.Hourglass False
+        
+        SetParameter "ExportPfad", TExportFile
+        DoCmd.Close
+        
+    Else
+     MsgBox ("Bitte wählen Sie eine Zweigstelle aus !")
+    End If
+
+Else
+ MsgBox ("Bitte wählen Sie zuerst aus, welche Daten Sie exportieren wollen !")
+End If
+
+End Sub
+
+
+
+Sub ExportAll(filename As String, ZNR1 As Long, Lesejahr1 As Long)
+
+
+Dim db1 As Database
+Dim rs1 As Recordset
+Dim db2 As Database
+Dim rs2 As Recordset
+Dim item1
+Dim i As Integer
+Dim tempfilename1 As String
+Dim filename1 As String
+Dim query1 As String
+Dim datapath As String
+
+datapath = GetDataPath
+
+
+' Create new database
+    
+
+ If Fileexists(filename) Then FileSystem.Kill (filename)
+  
+ Set db2 = Application.DBEngine.Workspaces(0).CreateDatabase(filename, dbLangGeneral)
+ db2.Close
+
+ 'TLieferungen
+ 
+ If OLieferungen = True Then
+      
+     filename1 = "TLieferungen"
+     tempfilename1 = "xTLieferungen"
+     query1 = "SELECT * FROM TLieferungen WHERE ZNR=" + Format(ZNR1) + " AND Year(Datum)=" + Format(Lesejahr1)
+     
+     Set db2 = Application.DBEngine.Workspaces(0).OpenDatabase(filename)
+     Set db1 = CurrentDb
+    
+     DoCmd.TransferDatabase acImport, "Microsoft Access", datapath, acTable, filename1, tempfilename1, True
+     DoCmd.TransferDatabase acExport, "Microsoft Access", filename, acTable, tempfilename1, tempfilename1, True
+     DoCmd.DeleteObject acTable, tempfilename1
+    
+     Set rs2 = db2.OpenRecordset(tempfilename1)
+     Set rs1 = db1.OpenRecordset(query1)
+    
+     While Not rs1.EOF
+      rs2.AddNew
+      For item1 = 0 To db2.TableDefs(tempfilename1).Fields.Count - 1
+       rs2(item1) = rs1(item1)
+      Next item1
+      rs2.Update
+      rs1.MoveNext
+     Wend
+     
+     
+     Dim lieferungen As Integer
+     
+     lieferungen = rs1.recordcount
+     
+     rs1.Close
+     rs2.Close
+     db1.Close
+     db2.Close
+     
+     
+    
+    
+     'TLieferungAbschlag
+     filename1 = "TLieferungAbschlag"
+     tempfilename1 = "xTLieferungAbschlag"
+     query1 = "SELECT TLieferungAbschlag.* FROM TLieferungAbschlag INNER JOIN TLieferungen ON TLieferungAbschlag.LINR = TLieferungen.LINR WHERE ZNR=" + Format(ZNR1) + " AND Year(Datum)=" + Format(Lesejahr1)
+     
+     Set db2 = Application.DBEngine.Workspaces(0).OpenDatabase(filename)
+     Set db1 = CurrentDb
+    
+     DoCmd.TransferDatabase acImport, "Microsoft Access", datapath, acTable, filename1, tempfilename1, True
+     DoCmd.TransferDatabase acExport, "Microsoft Access", filename, acTable, tempfilename1, tempfilename1, True
+     DoCmd.DeleteObject acTable, tempfilename1
+    
+     Set rs2 = db2.OpenRecordset(tempfilename1)
+     Set rs1 = db1.OpenRecordset(query1)
+    
+     While Not rs1.EOF
+      rs2.AddNew
+      For item1 = 0 To db2.TableDefs(tempfilename1).Fields.Count - 1
+       rs2(item1) = rs1(item1)
+      Next item1
+      rs2.Update
+      rs1.MoveNext
+     Wend
+     'MsgBox (Format(rs1.RecordCount) + " Lieferungs-Abschläge exportiert")
+     rs1.Close
+     rs2.Close
+     db1.Close
+     db2.Close
+     
+    
+     MsgBox (Format(lieferungen) + " Lieferungen exportiert")
+     
+ End If
+
+
+ 'TMitglieder
+ 
+ If OMitglieder = True Then
+ 
+     filename1 = "TMitglieder"
+     tempfilename1 = "xTMitglieder"
+     query1 = "SELECT * FROM TMitglieder WHERE ZNR=" + Format(ZNR1)
+     
+     Set db2 = Application.DBEngine.Workspaces(0).OpenDatabase(filename)
+     Set db1 = CurrentDb
+    
+     DoCmd.TransferDatabase acImport, "Microsoft Access", datapath, acTable, filename1, tempfilename1, True
+     DoCmd.TransferDatabase acExport, "Microsoft Access", filename, acTable, tempfilename1, tempfilename1, True
+     DoCmd.DeleteObject acTable, tempfilename1
+    
+     Set rs2 = db2.OpenRecordset(tempfilename1)
+     Set rs1 = db1.OpenRecordset(query1)
+    
+     While Not rs1.EOF
+      rs2.AddNew
+      For item1 = 0 To db2.TableDefs(tempfilename1).Fields.Count - 1
+       rs2(item1) = rs1(item1)
+      Next item1
+      rs2.Update
+      rs1.MoveNext
+     Wend
+     MsgBox (Format(rs1.recordcount) + " Mitglieder exportiert")
+     rs1.Close
+     rs2.Close
+     db1.Close
+     db2.Close
+    
+     'TFlaechenbindungen
+     filename1 = "TFlaechenbindungen"
+     tempfilename1 = "xTFlaechenbindungen"
+     query1 = "SELECT TFlaechenbindungen.* FROM TMitglieder INNER JOIN TFlaechenbindungen ON TMitglieder.MGNR = TFlaechenbindungen.MGNR WHERE ZNR = " + Format(ZNR1)
+     
+     Set db2 = DBEngine.Workspaces(0).OpenDatabase(filename)
+     Set db1 = CurrentDb
+    
+     DoCmd.TransferDatabase acImport, "Microsoft Access", datapath, acTable, filename1, tempfilename1, True
+     DoCmd.TransferDatabase acExport, "Microsoft Access", filename, acTable, tempfilename1, tempfilename1, True
+     DoCmd.DeleteObject acTable, tempfilename1
+    
+     Set rs2 = db2.OpenRecordset(tempfilename1)
+     Set rs1 = db1.OpenRecordset(query1)
+    
+     While Not rs1.EOF
+      rs2.AddNew
+      For item1 = 0 To (db2.TableDefs(tempfilename1).Fields.Count - 1)
+       rs2(item1) = rs1(item1)
+      Next item1
+      
+      rs2.Update
+      rs1.MoveNext
+     Wend
+     MsgBox (Format(rs1.recordcount) + " Flächenbindungen exportiert")
+     rs1.Close
+     rs2.Close
+     db1.Close
+     db2.Close
+End If
+
+'TChargen
+If OChargen = True Then
+      
+     filename1 = "TChargen"
+     tempfilename1 = "xTChargen"
+     query1 = "SELECT * FROM TChargen WHERE ZNR=" + Format(ZNR1) + " AND Jahrgang=" + Format(Lesejahr1)
+     
+     Set db2 = Application.DBEngine.Workspaces(0).OpenDatabase(filename)
+     Set db1 = CurrentDb
+    
+     DoCmd.TransferDatabase acImport, "Microsoft Access", datapath, acTable, filename1, tempfilename1, True
+     DoCmd.TransferDatabase acExport, "Microsoft Access", filename, acTable, tempfilename1, tempfilename1, True
+     DoCmd.DeleteObject acTable, tempfilename1
+    
+     Set rs2 = db2.OpenRecordset(tempfilename1)
+     Set rs1 = db1.OpenRecordset(query1)
+    
+     While Not rs1.EOF
+      rs2.AddNew
+      For item1 = 0 To db2.TableDefs(tempfilename1).Fields.Count - 1
+       rs2(item1) = rs1(item1)
+      Next item1
+      rs2.Update
+      rs1.MoveNext
+     Wend
+     
+     MsgBox (Format(rs1.recordcount) + " Chargen exportiert")
+     
+     rs1.Close
+     rs2.Close
+     db1.Close
+     db2.Close
+
+ End If
+
+
+
+
+
+Exit Sub
+
+WhatIsLos:
+ MsgBox ("Error")
+
+
+End Sub
+
+
+
+
+
+
+Private Sub Form_Open(Cancel As Integer)
+
+TZNR = DFirst("ZNR", "TZweigstellen")
+If Month(Date) < 9 Then
+ TLesejahr = year(Date) - 1
+Else
+ TLesejahr = year(Date)
+End If
+OListe = 1
+
+Dim filename
+
+filename = GetParameter("ExportPfad")
+
+If Len(filename) > 0 Then
+ TExportFile = filename
+End If
+
+
+End Sub
+
+
+Private Sub OChargen_Click()
+
+If OLieferungen = True Or OChargen = True Then
+ TLesejahr.Visible = True
+ XLesejahr.Visible = True
+Else
+ TLesejahr.Visible = False
+ XLesejahr.Visible = False
+End If
+
+End Sub
+
+Private Sub OLieferungen_Click()
+
+If OLieferungen = True Or OChargen = True Then
+ TLesejahr.Visible = True
+ XLesejahr.Visible = True
+Else
+ TLesejahr.Visible = False
+ XLesejahr.Visible = False
+End If
+
+End Sub
+
+Function Fileexists(filename As String) As Boolean
+
+On Error GoTo NoFile
+
+If FileSystem.GetAttr(filename) >= 0 Then
+ Fileexists = True
+Else
+ Fileexists = False
+End If
+
+Exit Function
+
+NoFile:
+ Fileexists = False
+ Exit Function
+
+End Function

wgmaster/vba/Form_MExportBKIListe.frm

@@ -0,0 +1,380 @@
+
+
+Private Sub BOk_Click()
+
+If Fileexists(TExportDatei) Then
+ If MsgBox("Datei " + TExportDatei + " existiert bereits ! Überschreiben", vbYesNo) = vbYes Then
+  ExportBKI TExportDatei, TLesejahr
+  'DoCmd.Close
+ End If
+Else
+
+If Not IsNull(TExportDatei) And TExportDatei <> "" Then
+  ExportBKI TExportDatei, TLesejahr
+ Else
+  MsgBox "Bitte geben Sie eine Exportdatei an !", vbCritical
+ End If
+End If
+
+End Sub
+
+
+Private Sub Form_Close()
+
+If Not IsNull(TExportDatei) And TExportDatei <> "" Then
+ SetParameter "BKIEXPORTDATEI", TExportDatei
+End If
+
+End Sub
+
+Private Sub Form_Open(Cancel As Integer)
+
+
+If IsNull(GetParameter("BKIEXPORTDATEI")) Then
+ SetParameter "BKIEXPORTDATEI", "C:\BKILISTE.TXT"
+End If
+
+TExportDatei = GetParameter("BKIEXPORTDATEI")
+
+If Month(Date) < 9 Then
+ TLesejahr = year(Date) - 1
+Else
+ TLesejahr = year(Date)
+End If
+
+End Sub
+
+
+
+Sub ExportBKI(filename1 As String, Lesejahr1 As Long)
+
+
+Dim db1 As Database
+Dim rs1 As Recordset
+Dim line1 As String
+Dim filenum
+Dim query1 As String
+Dim where1 As String
+Dim order1 As String
+
+Dim wg_betriebsnummer As String
+Dim wg_name As String
+Dim wg_vorname As String
+Dim wg_strasse As String
+Dim wg_hausnr As String
+Dim wg_plz As String
+Dim wg_ort As String
+Dim mg_betriebsnummer As String
+Dim mg_name As String
+Dim mg_vorname As String
+Dim mg_strasse As String
+Dim mg_hausnr As String
+Dim mg_plz As String
+Dim mg_ort As String
+Dim li_datum As String
+Dim li_menge As String
+Dim li_art As String
+Dim li_weiss As String
+Dim li_rot As String
+Dim li_sorte1 As String
+Dim li_sorte2 As String
+Dim li_sorte3 As String
+Dim li_qualitaetsstufe As String
+Dim li_jahrgang As String
+Dim li_herkunft As String
+Dim li_kwm As String
+Dim li_oechsle As String
+Dim mg_vollablieferer As String
+Dim mg_hagesamt As String
+Dim mg_haertrag As String
+Dim mg_flaechenbindung As String
+Dim rcount As Long
+Dim gcount As Double
+
+Set db1 = CurrentDb
+DoCmd.Hourglass True
+
+'WG-Betriebsnummer
+'WG-Name
+'WG-Vorname
+'WG-Straße
+'WG-Hausnr
+'WG-Plz
+'WG-Ort
+'MG-Betriebsnummer
+'MG-Name
+'MG-Vorname
+'MG-Straße
+'MG-Hausnr
+'MG-Plz
+'MG-Ort
+'Lieferung-Datum
+'Lieferung-Menge in kg
+'Lieferung-Art='TB'
+'Lieferung-Weiß='J' oder leer
+'Lieferung-Rot='J' oder leer
+'Lieferung-Sorte1
+'Lieferung-Sorte2
+'Lieferung-Sorte3
+'Lieferung-Qualitätsstufe
+'Lieferung-Jahrgang
+'Lieferung-Herkunft
+'Lieferung-KMW
+'Lieferung-Oe
+'Vollablieferer
+'Ha gesamt
+'Ha ertragsfähig
+'Flächenbindung in Ha
+
+rcount = 0
+gcount = 0
+wg_betriebsnummer = GetParameter("MANDANTENBETRIEBSNUMMER")
+wg_name = GetParameter("MANDANTENNAME1")
+wg_vorname = GetParameter("MANDANTENNAME2")
+ExtractFromStrasse GetParameter("MANDANTENSTRASSE"), wg_strasse, wg_hausnr
+wg_plz = GetParameter("MANDANTENPLZ")
+wg_ort = GetParameter("MANDANTENORT")
+
+query1 = "SELECT TMitglieder.MGNR, TMitglieder.Betriebsnummer, TMitglieder.Nachname, TMitglieder.Vorname, TMitglieder.Straße, TMitglieder.PLZ, TMitglieder.Ort, TLieferungen.Datum, TLieferungen.Gewicht, TSorten.Typ, TSorten.Bezeichnung, TQualitaetsstufen.BKIKuerzel, TLieferungen.SNR, TRegionen.BKIKuerzel, TGebiete.BKIKuerzel, TUmrechnung.KW, TLieferungen.Oechsle,TLieferungen.GNR,TLieferungen.QSNR,TLieferungen.SNR FROM TRegionen RIGHT JOIN (TGebiete RIGHT JOIN (TGrosslagen RIGHT JOIN (TGemeinden RIGHT JOIN (((TSorten INNER JOIN (TMitglieder INNER JOIN TLieferungen ON TMitglieder.MGNR = TLieferungen.MGNR) ON TSorten.SNR = TLieferungen.SNR) LEFT JOIN TUmrechnung ON TLieferungen.Oechsle = TUmrechnung.Oechsle) LEFT JOIN TQualitaetsstufen ON TLieferungen.QSNR = TQualitaetsstufen.QSNR) ON TGemeinden.GNR = TLieferungen.GNR) ON TGrosslagen.GLNR = TGemeinden.GLNR) ON TGebiete.WBGNR = TGrosslagen.WBGNR) ON TRegionen.RGNR = TGebiete.RGNR"
+where1 = " WHERE Year(TLieferungen.Datum)=" + Format(Lesejahr1) + " AND  TLieferungen.Gewicht>0"
+order1 = " ORDER BY TMitglieder.Nachname, TMitglieder.Vorname, TMitglieder.MGNR"
+
+filenum = FreeFile
+Open filename1 For Output As filenum
+
+Set rs1 = db1.OpenRecordset(query1 + where1 + order1)
+While Not rs1.EOF
+ If Not IsNull(rs1!Betriebsnummer) Then
+  mg_betriebsnummer = rs1!Betriebsnummer
+ Else
+  mg_betriebsnummer = ""
+ End If
+ If Not IsNull(rs1!Nachname) Then
+  mg_name = rs1!Nachname
+ Else
+  mg_name = ""
+ End If
+ If Not IsNull(rs1!Vorname) Then
+  mg_vorname = rs1!Vorname
+ Else
+  mg_vorname = ""
+ End If
+ If Not IsNull(rs1!Straße) Then
+  ExtractFromStrasse rs1![Straße], mg_strasse, mg_hausnr
+ Else
+  mg_strasse = ""
+  mg_hausnr = ""
+ End If
+ 
+ If Not IsNull(rs1!PLZ) Then
+  mg_plz = Format(rs1!PLZ, "0")
+ Else
+  mg_plz = ""
+ End If
+ 
+ 'If left(rs1!Ort, 5) = "MERKE" Then
+  'MsgBox (rs1!Ort)
+ 'End If
+ 
+ If Not IsNull(rs1!Ort) Then
+  mg_ort = rs1!Ort
+  If (mg_strasse = "" Or mg_hausnr = "") And InStr(mg_ort, " ") > 0 Then
+   'straße steht im ort
+   ExtractFromStrasse rs1!Ort, mg_ort, mg_hausnr
+  End If
+ Else
+  mg_ort = ""
+ End If
+ If Not IsNull(rs1!Datum) Then
+  li_datum = Format(rs1!Datum, "dd.mm.yyyy")
+ Else
+  li_datum = ""
+ End If
+ If Not IsNull(rs1!Gewicht) Then
+  li_menge = Format(rs1!Gewicht)
+ Else
+  li_menge = ""
+ End If
+ 
+ li_art = "TB"
+ 
+ li_weiss = ""
+ li_rot = ""
+ If Not IsNull(rs1!Typ) Then
+  If rs1!Typ = "Weiß" Then
+   li_weiss = "J"
+  End If
+  If rs1!Typ = "Rot" Then
+   li_rot = "J"
+  End If
+ End If
+ If Not IsNull(rs1!SNR) Then
+  li_sorte1 = Left(rs1!SNR, 2)
+ Else
+  li_sorte1 = ""
+ End If
+ li_sorte2 = ""
+ li_sorte3 = ""
+ 
+ If Not IsNull(rs1![TQualitaetsstufen.BKIKuerzel]) Then
+  li_qualitaetsstufe = rs1![TQualitaetsstufen.BKIKuerzel]
+ Else
+  li_qualitaetsstufe = ""
+ End If
+
+ li_jahrgang = Format(Lesejahr1)
+ 
+ 
+ 'obsolet
+ 'If Not IsNull(rs1![TRegionen.BKIKuerzel]) Then
+ ' li_herkunft = rs1![TRegionen.BKIKuerzel]
+ 'Else
+ ' li_herkunft = ""
+ 'End If
+ 
+ 'If rs1![SNR] = "DAC" Then
+ ' li_sorte1 = "GV"
+ ' If Not IsNull(rs1![TGebiete.BKIKuerzel]) Then
+ '     li_herkunft = rs1![TGebiete.BKIKuerzel]
+ ' End If
+ 'End If
+ 
+ If Not IsNull(rs1!SNR) And Not IsNull(rs1!QSNR) And Not IsNull(rs1!GNR) Then
+  li_herkunft = GetHerkunftBKI(rs1!SNR, rs1!QSNR, rs1!GNR)
+ Else
+  li_herkunft = ""
+  'hardcoded
+  If rs1!QSNR < 3 Then
+   If rs1!QSNR < 2 Then
+    li_herkunft = "OEST"
+   Else
+    li_herkunft = "WLXX"
+   End If
+  Else
+   If UCase(Left(rs1!SNR, 2)) = "GV" Then
+    li_herkunft = "WLWV"
+   Else
+    li_herkunft = "WLNO"
+   End If
+  End If
+ End If
+ 
+ If Not IsNull(rs1!KW) Then
+  li_kwm = rs1!KW
+ Else
+  li_kwm = ""
+ End If
+ 
+ If Not IsNull(rs1!Oechsle) Then
+  li_oechsle = rs1!Oechsle
+ Else
+  li_oechsle = ""
+ End If
+ 
+ mg_vollablieferer = "N"
+ mg_hagesamt = ""
+ mg_haertrag = ""
+ 'mg_flaechenbindung = ""
+ 
+ mg_flaechenbindung = Format(Get_Flaechenbindung(rs1!MGNR, Lesejahr1))
+ 
+
+ line1 = wg_betriebsnummer + Chr(9) + wg_name + Chr(9) + wg_vorname + Chr(9) + wg_strasse + Chr(9) + wg_hausnr + Chr(9) + wg_plz + Chr(9) + wg_ort + Chr(9)
+ line1 = line1 + mg_betriebsnummer + Chr(9) + mg_name + Chr(9) + mg_vorname + Chr(9) + mg_strasse + Chr(9) + mg_hausnr + Chr(9) + mg_plz + Chr(9) + mg_ort + Chr(9)
+ line1 = line1 + li_datum + Chr(9) + li_menge + Chr(9) + li_art + Chr(9) + li_weiss + Chr(9) + li_rot + Chr(9) + li_sorte1 + Chr(9) + li_sorte2 + Chr(9) + li_sorte3 + Chr(9) + li_qualitaetsstufe + Chr(9) + li_jahrgang + Chr(9) + li_herkunft + Chr(9) + li_kwm + Chr(9) + li_oechsle + Chr(9)
+ line1 = line1 + mg_vollablieferer + Chr(9) + mg_hagesamt + Chr(9) + mg_haertrag + Chr(9) + mg_flaechenbindung
+ Print #filenum, line1
+ rcount = rcount + 1
+ gcount = gcount + rs1!Gewicht
+ rs1.MoveNext
+Wend
+rs1.Close
+Close filenum
+DoCmd.Hourglass False
+MsgBox (Format(rcount) + " Lieferungen exportiert. Gesamtgewicht: " + Format(gcount) + " kg")
+
+
+
+End Sub
+
+Function Get_Flaechenbindung(mgnr1 As Long, Lesejahr1 As Long) As Double
+
+Dim x
+
+x = DSum("Flaeche", "TFlaechenbindungen", "MGNR=" + Format(mgnr1) + " AND Von<=" + Format(Lesejahr1) + " AND (Bis>=" + Format(Lesejahr1) + " or Bis=Null)")
+
+If IsNull(x) Then
+ Get_Flaechenbindung = 0
+Else
+ Get_Flaechenbindung = x
+End If
+
+End Function
+
+
+
+Function Fileexists(filename As String) As Boolean
+
+On Error GoTo NoFile
+
+If FileSystem.GetAttr(filename) >= 0 Then
+ Fileexists = True
+Else
+ Fileexists = False
+End If
+
+Exit Function
+
+NoFile:
+ Fileexists = False
+ Exit Function
+
+End Function
+
+
+Public Function Runden(value1 As Double, digits As Integer) As Double
+
+Dim temp1 As Double
+
+temp1 = value1 * (10 ^ digits)
+
+If (temp1 * 10) Mod 10 = 5 Then
+ temp1 = temp1 + 1
+ temp1 = Fix(temp1)
+ temp1 = temp1 / (10 ^ digits)
+ Runden = temp1
+Else
+ Runden = CLng(value1 * (10 ^ digits)) / (10 ^ digits)
+End If
+
+End Function
+
+Sub ExtractFromStrasse(str1 As String, strasse1 As String, hausnummer1 As String)
+
+Dim rightestspacepos As Long
+
+If IsNumeric(str1) Then
+    hausnummer1 = str1
+    strasse1 = ""
+Else
+    rightestspacepos = Len(str1)
+    While Mid(str1, rightestspacepos, 1) <> " " And rightestspacepos > 1
+     rightestspacepos = rightestspacepos - 1
+    Wend
+    
+    
+    'If InStr(str1, " ") > 0 Then
+    If rightestspacepos > 1 Then
+     'strasse1 = left(str1, InStr(str1, " ") - 1)
+     'hausnummer1 = Mid(str1, InStr(str1, " ") + 1)
+     strasse1 = Left(str1, rightestspacepos - 1)
+     hausnummer1 = Mid(str1, rightestspacepos + 1)
+    Else
+     strasse1 = str1
+     hausnummer1 = ""
+    End If
+End If
+
+End Sub
+
+

wgmaster/vba/Form_MExportMitglieder.frm

@@ -0,0 +1,412 @@
+
+'Globals for data exchange with export functions
+
+Dim mgnr1 As String
+Dim nachname1 As String
+Dim vorname1 As String
+Dim strasse1 As String
+Dim plz1 As String
+Dim ort1 As String
+Dim betriebsnummer1 As String
+Dim ga1 As String
+Dim ga2 As String
+Dim eintrittsdatum1 As String
+Dim austrittsdatum1 As String
+Dim buchführend1 As String
+Dim anmerkung1 As String
+Dim aktivesmitglied1 As String
+
+Dim bhkontonr1 As String
+Dim blz1 As String
+Dim bankname1 As String
+Dim bankname2 As String
+Dim kontonr1 As String
+
+Dim zweigstelle1 As String
+
+'Globals for bmd export
+
+Dim Branche1 As String
+Dim Auslandscode1 As String
+Dim Zahlungsziel1 As String
+Dim Skonto1 As String
+Dim Skonto2 As String
+Dim Mahncode1 As String
+Dim Verkaufsgebiet1 As String
+
+Private Sub BOk_Click()
+
+If Fileexists(TExportDatei) Then
+ If MsgBox("Datei " + TExportDatei + " existiert bereits ! Überschreiben", vbYesNo) = vbYes Then
+  ExportMitglieder (TExportDatei)
+  DoCmd.Close
+ End If
+Else
+ If Not IsNull(TExportDatei) And TExportDatei <> "" Then
+  ExportMitglieder (TExportDatei)
+  DoCmd.Close
+ Else
+  MsgBox "Bitte geben Sie eine Exportdatei an !", vbCritical
+ End If
+End If
+
+End Sub
+
+
+Private Sub Form_Close()
+
+If Not IsNull(TExportDatei) And TExportDatei <> "" Then
+ Select Case OExportOption
+  Case 1: ' CDF
+          SetParameter "MITGLIEDEREXPORTDATEI1", TExportDatei
+  Case 2: ' BMD
+          SetParameter "MITGLIEDEREXPORTDATEI2", TExportDatei
+ End Select
+ 
+End If
+
+SetParameter "MITGLIEDEREXPORTDEFAULT", OExportOption
+
+End Sub
+
+
+
+Private Sub Form_Open(Cancel As Integer)
+
+If IsNull(GetParameter("MITGLIEDEREXPORTDEFAULT")) Then
+ SetParameter "MITGLIEDEREXPORTDEFAULT", 1
+End If
+
+OExportOption = GetParameter("MITGLIEDEREXPORTDEFAULT")
+
+Select Case OExportOption
+
+Case 1: 'CDF
+      If IsNull(GetParameter("MITGLIEDEREXPORTDATEI1")) Then
+       SetParameter "MITGLIEDEREXPORTDATEI1", "C:\MITGLIEDER.TXT"
+      End If
+      TExportDatei = GetParameter("MITGLIEDEREXPORTDATEI1")
+Case 2: 'BMD
+      If IsNull(GetParameter("MITGLIEDEREXPORTDATEI2")) Then
+       SetParameter "MITGLIEDEREXPORTDATEI2", "C:\PEKOSTAM.BMD"
+      End If
+      TExportDatei = GetParameter("MITGLIEDEREXPORTDATEI2")
+
+End Select
+
+End Sub
+
+
+
+Function Fileexists(filename As String) As Boolean
+
+On Error GoTo NoFile
+
+If FileSystem.GetAttr(filename) >= 0 Then
+ Fileexists = True
+Else
+ Fileexists = False
+End If
+
+Exit Function
+
+NoFile:
+ Fileexists = False
+ Exit Function
+
+End Function
+
+
+Sub ExportMitglieder(filename1 As String)
+
+Dim db1 As Database
+Dim rs_mitglieder As Recordset
+Dim query1 As String
+Dim Lesejahr1 As Long
+Dim rcounter As Long
+Dim line1 As String
+Dim filenum
+
+DoCmd.Hourglass True
+
+query1 = "SELECT TMitglieder.*, TZweigstellen.Name, TBanken.Name1, TBanken.Name2, TMitglieder.Nachname, TMitglieder.Vorname FROM (TBanken RIGHT JOIN TMitglieder ON TBanken.BLZ = TMitglieder.BLZ) LEFT JOIN TZweigstellen ON TMitglieder.ZNR = TZweigstellen.ZNR ORDER BY TMitglieder.Nachname, TMitglieder.Vorname"
+
+Set db1 = CurrentDb
+Set rs_mitglieder = db1.OpenRecordset(query1)
+
+rcounter = 0
+sum_netto1 = 0
+sum_mwst1 = 0
+sum_brutto1 = 0
+
+filenum = FreeFile
+
+On Error GoTo err1:
+Open filename1 For Output As filenum
+
+ Select Case OExportOption
+ 
+ Case 1: ' CDF
+           PrintMitgliederCDFHeader (filenum)
+ Case 2: ' BMD
+           PrintMitgliederBMDHeader (filenum)
+ End Select
+
+While Not rs_mitglieder.EOF
+ 
+ mgnr1 = Format(rs_mitglieder![MGNR])
+ If IsNull(rs_mitglieder![TMitglieder.Nachname]) Then nachname1 = "" Else nachname1 = rs_mitglieder![TMitglieder.Nachname]
+ If IsNull(rs_mitglieder![TMitglieder.Vorname]) Then vorname1 = "" Else vorname1 = rs_mitglieder![TMitglieder.Vorname]
+ If IsNull(rs_mitglieder![Straße]) Then strasse1 = "" Else strasse1 = rs_mitglieder![Straße]
+ If IsNull(rs_mitglieder![PLZ]) Then plz1 = "" Else plz1 = rs_mitglieder!PLZ
+ If IsNull(rs_mitglieder!Ort) Then ort1 = "" Else ort1 = rs_mitglieder!Ort
+ 
+ If IsNull(rs_mitglieder!BLZ) Then blz1 = "" Else blz1 = rs_mitglieder!BLZ
+ If IsNull(rs_mitglieder!KontoNr) Then kontonr1 = "" Else kontonr1 = rs_mitglieder!KontoNr
+ If IsNull(rs_mitglieder!BHKontonummer) Then bhkontonr1 = "" Else bhkontonr1 = rs_mitglieder!BHKontonummer
+ If IsNull(rs_mitglieder!Name1) Then bankname1 = "" Else bankname1 = rs_mitglieder!Name1
+ If IsNull(rs_mitglieder!Name2) Then bankname2 = "" Else bankname2 = rs_mitglieder!Name2
+ 
+ If IsNull(rs_mitglieder!Name) Then zweigstelle1 = "" Else zweigstelle1 = rs_mitglieder!Name
+ 
+ If IsNull(rs_mitglieder!Betriebsnummer) Then betriebsnummer1 = "" Else betriebsnummer1 = rs_mitglieder!Betriebsnummer
+ If IsNull(rs_mitglieder![Geschäftsanteile1]) Then ga1 = "" Else ga1 = rs_mitglieder![Geschäftsanteile1]
+ If IsNull(rs_mitglieder![Geschäftsanteile2]) Then ga2 = "" Else ga2 = rs_mitglieder![Geschäftsanteile2]
+ 
+ If IsNull(rs_mitglieder![Eintrittsdatum]) Then eintrittsdatum1 = "" Else eintrittsdatum1 = Format(rs_mitglieder![Eintrittsdatum], "dd.mm.yyyy")
+ If IsNull(rs_mitglieder![Austrittsdatum]) Then austrittsdatum1 = "" Else austrittsdatum1 = Format(rs_mitglieder![Austrittsdatum], "dd.mm.yyyy")
+  
+ If rs_mitglieder![Buchführend] Then buchführend1 = "buchführend" Else buchführend1 = ""
+ 
+ If IsNull(rs_mitglieder![Anmerkung]) Then anmerkung1 = "" Else anmerkung1 = rs_mitglieder![Anmerkung]
+ If rs_mitglieder![Aktives Mitglied] Then aktivesmitglied1 = "aktiv" Else aktivesmitglied1 = ""
+
+  ' output to file
+ 
+ Select Case OExportOption
+ 
+ Case 1: ' CDF
+           PrintMitgliederCDFData (filenum)
+ Case 2: ' BMD
+           PrintMitgliederBMDData (filenum)
+ End Select
+ 
+ rs_mitglieder.MoveNext
+ rcounter = rcounter + 1
+Wend
+
+Close filenum
+rs_mitglieder.Close
+
+DoCmd.Hourglass False
+
+MsgBox (Format(rcounter) + " Mitglieder erfolgreich exportiert !")
+Exit Sub
+
+err1:
+ MsgBox "Datei bereits geöffnet !", vbCritical
+ DoCmd.Hourglass False
+
+End Sub
+
+Private Sub OExportOption_Click()
+
+Select Case OExportOption
+
+Case 1: 'CDF
+      If IsNull(GetParameter("MITGLIEDEREXPORTDATEI1")) Then
+       SetParameter "MITGLIEDEREXPORTDATEI1", "C:\MITGLIEDER.TXT"
+      End If
+      TExportDatei = GetParameter("MITGLIEDEREXPORTDATEI1")
+Case 2: 'BMD
+      If IsNull(GetParameter("MITGLIEDEREXPORTDATEI2")) Then
+       SetParameter "MITGLIEDEREXPORTDATEI2", "C:\PEKOSTAM.BMD"
+      End If
+      TExportDatei = GetParameter("MITGLIEDEREXPORTDATEI2")
+
+End Select
+
+
+
+
+End Sub
+
+
+
+
+
+' ******************************************************************************
+' THE EXPORT ROUTINES
+' ******************************************************************************
+
+
+' ******************************************************************************
+' CDF EXPORT
+' ******************************************************************************
+
+
+Sub PrintMitgliederCDFData(filenumber)
+
+Dim s1 As String
+s1 = ";"
+
+Print #filenumber, mgnr1 + s1 + nachname1 + s1 + vorname1 + s1 + strasse1 + s1 + plz1 + s1 + ort1 + s1 + kontonr1 + s1 + blz1 + s1 + bankname1 + s1 + bankname2 + s1 + zweigstelle1 + s1 + betriebsnummer1 + s1 + ga1 + s1 + ga2 + s1 + Format(eintrittsdatum1) + s1 + Format(austrittsdatum1) + s1 + buchführend1 + s1 + aktivesmitglied1
+
+End Sub
+
+
+Sub PrintMitgliederCDFHeader(filenumber)
+
+Dim line1 As String
+Dim s1 As String
+s1 = ";"
+line1 = ""
+
+Print #filenumber, "MITGLIEDERLISTE"
+
+Print #filenumber, ""
+Print #filenumber, "MITGLIEDSNUMMER" + s1 + "NACHNAME" + s1 + "VORNAME" + s1 + "STRASSE" + s1 + "PLZ" + s1 + "ORT" + s1 + "KONTONUMMER" + s1 + "BLZ" + s1 + "BANKNAME1" + s1 + "BANKNAME2" + s1 + "ZWEIGSTELLE" + s1 + "BETRIEBSNUMMER" + s1 + "GESCHÄFTSANTEILE1" + s1 + "GESCHÄFTSANTEILE2" + s1 + "EINTRITT" + s1 + "AUSTRITT" + s1 + "BUCHFÜHREND" + s1 + "AKTIVES MITGLIED"
+
+End Sub
+
+
+' ******************************************************************************
+' BMD EXPORT
+' ******************************************************************************
+
+
+Sub PrintMitgliederBMDData(filenumber)
+
+Dim line1 As String
+Dim str1 As String
+
+line1 = ""
+str1 = ""
+
+'bhkontonr
+str1 = FillUp(bhkontonr1, 6, 1, "0")
+line1 = line1 + str1
+'MsgBox (str1)
+
+'bezeichnung (name)
+str1 = FillUp(nachname1 + " " + vorname1, 30, 0, " ")
+line1 = line1 + str1
+'MsgBox (str1)
+
+'branche
+str1 = FillUp(Branche1, 25, 0, " ")
+line1 = line1 + str1
+'MsgBox (str1)
+
+'straße
+str1 = FillUp(strasse1, 20, 0, " ")
+line1 = line1 + str1
+'MsgBox (str1)
+
+'plz
+str1 = FillUp(plz1, 7, 0, " ")
+line1 = line1 + str1
+'MsgBox (str1)
+
+'ort
+str1 = FillUp(ort1, 20, 0, " ")
+line1 = line1 + str1
+'MsgBox (str1)
+
+'bankkonto
+str1 = FillUp(kontonr1, 20, 0, " ")
+line1 = line1 + str1
+'MsgBox (str1)
+
+'blz
+str1 = FillUp(blz1, 6, 0, " ")
+line1 = line1 + str1
+'MsgBox (str1)
+
+'auslandscode
+str1 = FillUp(Auslandscode1, 3, 1, "0")
+line1 = line1 + str1
+'MsgBox (str1)
+
+'Zahlungsziel
+str1 = FillUp(Zahlungsziel1, 3, 1, "0")
+line1 = line1 + str1
+'MsgBox (str1)
+
+'skonto %
+str1 = FillUp(Skonto1, 3, 1, "0")
+line1 = line1 + str1
+'MsgBox (str1)
+
+'skonto tage
+str1 = FillUp(Skonto2, 3, 1, "0")
+line1 = line1 + str1
+'MsgBox (str1)
+
+'mahncode
+str1 = FillUp(Mahncode1, 3, 1, "0")
+line1 = line1 + str1
+'MsgBox (str1)
+
+'verkaufsgebiet
+str1 = FillUp(Verkaufsgebiet1, 3, 1, "0")
+line1 = line1 + str1
+'MsgBox (str1)
+
+'platzhalter " "x47
+str1 = FillUp(" ", 47, 1, " ")
+line1 = line1 + str1
+'MsgBox (str1)
+
+'stern
+str1 = "*"
+line1 = line1 + str1
+'MsgBox (str1)
+
+Print #filenumber, line1
+
+End Sub
+
+
+
+Sub PrintMitgliederBMDHeader(filenumber)
+
+'DoCmd.OpenForm
+
+Branche1 = "                         "
+Auslandscode1 = "000"
+Zahlungsziel1 = "000"
+Skonto1 = "000"
+Skonto2 = "000"
+Mahncode1 = "000"
+Verkaufsgebiet1 = "000"
+
+DoCmd.Hourglass True
+
+End Sub
+
+
+Function FillUp(text1 As String, laenge1 As Long, left1 As Long, fillchar1 As String) As String
+
+Dim str1 As String
+
+str1 = text1
+
+If Len(str1) > laenge1 Then
+' it is too long
+ str1 = Left(str1, laenge1)
+End If
+
+While (Len(str1) < laenge1)
+ ' it is still too short
+ If left1 Then
+  str1 = fillchar1 + str1
+ Else
+  str1 = str1 + fillchar1
+ End If
+Wend
+
+
+FillUp = str1
+
+End Function

wgmaster/vba/Form_MHauptmenü.frm

@@ -0,0 +1,113 @@
+Private Sub BChargen_Click()
+
+DoCmd.OpenForm "MChargenAuswahl"
+
+End Sub
+
+Private Sub BMitglieder_Click()
+
+DoCmd.OpenForm "FMitglieder"
+
+End Sub
+
+Private Sub BLieferungen_Click()
+
+'Dim lj
+
+'lj = InputBox("Für welches Lesejahr wollen Sie die Lieferungen bearbeiten ?", "LESEJAHR", Year(Date))
+
+'On Error Resume Next
+'If Not IsNull(lj) And lj <> "" Then
+' If CLng(lj) > 1900 Then
+'  DoCmd.OpenForm "FLieferungen", , , "Year(Datum)=" + Format(lj)
+' End If
+'End If
+DoCmd.OpenForm "MLieferungAuswahl"
+
+End Sub
+
+Private Sub BAuswertungen_Click()
+
+DoCmd.OpenForm "MAuswertung"
+
+
+End Sub
+
+Private Sub BStammdaten_Click()
+
+DoCmd.OpenForm "MStammdaten"
+
+End Sub
+
+Private Sub BAuszahlung_Click()
+
+DoCmd.OpenForm "MAuszahlung"
+
+End Sub
+
+Private Sub BAdministration_Click()
+
+On Error Resume Next
+DoCmd.DeleteObject acForm, "MAdministrationCopy"
+DoCmd.CopyObject , "MAdministrationCopy", acForm, "MAdministration"
+DoCmd.OpenForm "MAdministrationCopy"
+
+End Sub
+
+Private Sub BÜbernahme_Click()
+
+Dim lj
+
+
+lj = InputBox("Bitte geben Sie das Lesejahr ein:", "LESEJAHR", year(Date))
+
+On Error Resume Next
+If Not IsNull(lj) And lj <> "" Then
+ If CLng(lj) > 1900 Then
+  DoCmd.OpenForm "FÜbernahme", , , "Year(Datum)=" + Format(lj)
+ End If
+End If
+End Sub
+
+Private Sub Bild14_DblClick(Cancel As Integer)
+
+'DoCmd.ShowToolbar "Menüleiste", acToolbarYes
+'DoCmd.ShowToolbar "Formularansicht", acToolbarYes
+'DoCmd.ShowToolbar "Datenbank", acToolbarYes
+SwitchToolbars (True)
+End Sub
+
+Private Sub BLeseplanung_Click()
+
+Dim lj
+
+lj = InputBox("Bitte geben Sie das Lesejahr ein:", "LESEJAHR", year(Date))
+
+On Error Resume Next
+If Not IsNull(lj) And lj <> "" Then
+ If CLng(lj) > 1900 Then
+  DoCmd.OpenForm "FLeseplanung", , , "Year(Datum)=" + Format(lj)
+  Forms("FLeseplanung").Lesejahr = lj
+  Forms("FLeseplanung").SetLesejahr (lj)
+ End If
+End If
+
+
+
+End Sub
+
+Private Sub Form_Close()
+
+DoCmd.ShowToolbar "Menüleiste", acToolbarYes
+DoCmd.ShowToolbar "Formularansicht", acToolbarYes
+DoCmd.ShowToolbar "Datenbank", acToolbarYes
+
+End Sub
+
+Private Sub Form_Open(Cancel As Integer)
+
+DoCmd.ShowToolbar "Menüleiste", acToolbarNo
+DoCmd.ShowToolbar "Formularansicht", acToolbarNo
+DoCmd.ShowToolbar "Datenbank", acToolbarNo
+
+End Sub

wgmaster/vba/Form_MImport.frm

@@ -0,0 +1,659 @@
+
+
+Private Sub BOk_Click()
+
+DoCmd.Hourglass True
+ImportLieferungen TImportFile
+ImportMitglieder TImportFile
+ImportChargen TImportFile
+DoCmd.Hourglass False
+SetParameter "ImportPfad", TImportFile
+DoCmd.Close
+
+
+End Sub
+
+
+Sub ImportLieferungen(filename As String)
+
+Dim db1 As Database
+Dim rs1 As Recordset
+Dim db2 As Database
+Dim rs2 As Recordset
+Dim rs3 As Recordset
+Dim rs4 As Recordset
+Dim item1 As Integer
+
+Dim tempfilename1 As String
+Dim filename1 As String
+Dim tempfilename2 As String
+Dim filename2 As String
+Dim query1 As String
+Dim query2 As String
+Dim Lesejahr1 As Long
+Dim ZNR1 As Long
+Dim newLINR As Long
+Dim oldLINR As Long
+Dim newFBNR As Long
+
+Dim endwhile1
+
+' get lesejahr1/znr1
+
+ Set db1 = Application.DBEngine.Workspaces(0).OpenDatabase(filename)
+ 
+ On Error GoTo TableNotFound
+ 
+ If IsNull(db1.TableDefs("xTLieferungen")) Then Exit Sub
+ 
+ Set rs1 = db1.OpenRecordset("xTLieferungen")
+ 
+ ' TLieferungen does not exist
+ If IsNull(rs1) Then Exit Sub
+ 
+  Lesejahr1 = year(rs1!Datum)
+  ZNR1 = rs1!ZNR
+  rs1.Close
+  db1.Close
+
+'TLieferungen
+ filename1 = "TLieferungen"
+ tempfilename1 = "xTLieferungen"
+ tempfilename2 = "xTLieferungAbschlag"
+ filename2 = "TLieferungAbschlag"
+
+ query1 = "SELECT * FROM xTLieferungen ORDER BY LINR"
+ query2 = "SELECT * FROM xTLieferungAbschlag ORDER BY LINR"
+ 
+ DoCmd.Hourglass False
+If MsgBox("Sollen vorhandene Lieferungen der Zweigstelle " + Format(ZNR1) + " vom Lesejahr " + Format(Lesejahr1) + " eingelesen und überschrieben werden ?", vbYesNo) = vbYes Then
+  DoCmd.Hourglass True
+  Set db2 = CurrentDb
+  db2.Execute ("DELETE TLieferungAbschlag.* FROM TLieferungAbschlag RIGHT JOIN TLieferungen ON TLieferungAbschlag.LINR = TLieferungen.LINR WHERE ZNR=" + Format(ZNR1) + " AND Year(Datum)=" + Format(Lesejahr1) + ";")
+  db2.Execute ("DELETE * FROM TLieferungen WHERE ZNR=" + Format(ZNR1) + " AND Year(Datum)=" + Format(Lesejahr1) + ";")
+
+
+ If IsNull(DMax("LINR", "TLieferungen")) Then
+  newLINR = 0
+ Else
+  newLINR = DMax("LINR", "TLieferungen")
+ End If
+ 
+ Set db1 = Application.DBEngine.Workspaces(0).OpenDatabase(filename)
+ Set db2 = CurrentDb
+ 
+ Set rs1 = db1.OpenRecordset(query1, dbOpenSnapshot)
+ Set rs2 = db2.OpenRecordset(filename1, dbOpenDynaset, dbAppendOnly)
+ Set rs3 = db1.OpenRecordset(query2, dbOpenSnapshot)
+ Set rs4 = db2.OpenRecordset(filename2, dbOpenDynaset, dbAppendOnly)
+
+ While Not rs1.EOF
+ 
+  ' Insert TLieferungen
+  newLINR = newLINR + 1
+  rs2.AddNew
+
+  
+  For item1 = 0 To db1.TableDefs(tempfilename1).Fields.Count - 1
+   rs2(item1) = rs1(item1)
+  Next item1
+  
+  oldLINR = rs1!LINR
+  rs2!LINR = newLINR
+  rs2.Update
+
+
+  ' Insert TLieferungAbschlag and substitute new LINR
+
+  endwhile1 = 0
+  While endwhile1 = 0
+   If rs3.EOF Then
+    endwhile1 = 1
+   Else
+    If rs3!LINR >= oldLINR Then
+     endwhile1 = 1
+    Else
+     rs3.MoveNext
+    End If
+   End If
+
+  Wend
+  
+  endwhile1 = 0
+  While endwhile1 = 0
+   If rs3.EOF Then
+    endwhile1 = 1
+   Else
+    If rs3!LINR = oldLINR Then
+    
+     rs4.AddNew
+     For item1 = 0 To db1.TableDefs(tempfilename2).Fields.Count - 1
+      rs4(item1) = rs3(item1)
+     Next item1
+   
+     rs4!LINR = newLINR
+     rs4.Update
+     rs3.MoveNext
+
+    Else
+     endwhile1 = 1
+    End If
+   End If
+   
+  Wend
+  
+  rs1.MoveNext
+ Wend
+ 
+ DoCmd.Hourglass False
+ MsgBox (Format(rs1.recordcount) + " Lieferungen importiert")
+ DoCmd.Hourglass True
+
+ rs1.Close
+ rs2.Close
+ rs3.Close
+ rs4.Close
+ db1.Close
+ db2.Close
+ 
+
+End If
+
+Exit Sub
+
+TableNotFound:
+
+ Exit Sub
+
+End Sub
+
+
+
+
+
+Sub ImportMitglieder(filename As String)
+
+Dim db1 As Database
+Dim rs1 As Recordset
+Dim db2 As Database
+Dim rs2 As Recordset
+Dim rs3 As Recordset
+Dim rs4 As Recordset
+Dim item1 As Integer
+
+Dim tempfilename1 As String
+Dim filename1 As String
+Dim tempfilename2 As String
+Dim filename2 As String
+Dim query1 As String
+Dim query2 As String
+Dim Lesejahr1 As Long
+Dim ZNR1 As Long
+Dim newLINR As Long
+Dim oldLINR As Long
+Dim newFBNR As Long
+
+Dim endwhile1
+
+' get lesejahr1/znr1
+
+ On Error GoTo TableNotFound
+
+ Set db1 = Application.DBEngine.Workspaces(0).OpenDatabase(filename)
+ Set rs1 = db1.OpenRecordset("xTMitglieder")
+ If IsNull(rs1) Then Exit Sub
+ 
+  ZNR1 = rs1!ZNR
+  rs1.Close
+  db1.Close
+
+
+'TMitglieder
+ filename1 = "TMitglieder"
+ tempfilename1 = "xTMitglieder"
+ tempfilename2 = "xTFlaechenbindungen"
+ filename2 = "TFlaechenbindungen"
+
+ query1 = "SELECT * FROM xTMitglieder ORDER BY MGNR"
+ query2 = "SELECT * FROM xTFlaechenbindungen ORDER BY MGNR"
+ 
+ DoCmd.Hourglass False
+ 
+ If MsgBox("Sollen vorhandene Mitglieder der Zweigstelle " + Format(ZNR1) + " eingelesen und überschrieben werden ?", vbYesNo) = vbYes Then
+  DoCmd.Hourglass True
+  Set db2 = CurrentDb
+  db2.Execute ("DELETE TFlaechenbindungen.* FROM TFlaechenbindungen RIGHT JOIN TMitglieder ON TFlaechenbindungen.MGNR = TMitglieder.MGNR WHERE ZNR=" + Format(ZNR1) + ";")
+  db2.Execute ("DELETE * FROM TMitglieder WHERE ZNR=" + Format(ZNR1) + ";")
+  
+
+ 
+ Set db1 = Application.DBEngine.Workspaces(0).OpenDatabase(filename)
+ Set db2 = CurrentDb
+ 
+ Set rs1 = db1.OpenRecordset(tempfilename1)
+ Set rs2 = db2.OpenRecordset(filename1)
+
+ While Not rs1.EOF
+  ' Insert TMitglieder
+  rs2.AddNew
+  
+  For item1 = 0 To db1.TableDefs(tempfilename1).Fields.Count - 1
+   rs2(item1) = rs1(item1)
+  Next item1
+  rs2.Update
+  rs1.MoveNext
+ Wend
+ 
+ DoCmd.Hourglass False
+ MsgBox (Format(rs1.recordcount) + " Mitglieder importiert")
+ DoCmd.Hourglass True
+ 
+ rs1.Close
+ rs2.Close
+ db1.Close
+ db2.Close
+
+
+ Set db1 = Application.DBEngine.Workspaces(0).OpenDatabase(filename)
+ Set db2 = CurrentDb
+ 
+ Set rs1 = db1.OpenRecordset(tempfilename2)
+ Set rs2 = db2.OpenRecordset(filename2)
+
+ If IsNull(DMax("FBNR", "TFlaechenbindungen")) Then
+  newFBNR = 0
+ Else
+  newFBNR = DMax("FBNR", "TFlaechenbindungen")
+ End If
+ 
+ While Not rs1.EOF
+  ' Insert TFlaechenbindungen
+  newFBNR = newFBNR + 1
+  rs2.AddNew
+  
+  For item1 = 0 To db1.TableDefs(tempfilename2).Fields.Count - 1
+   rs2(item1) = rs1(item1)
+  Next item1
+  rs2!FBNR = newFBNR
+  rs2.Update
+  rs1.MoveNext
+ Wend
+ DoCmd.Hourglass False
+ MsgBox (Format(rs1.recordcount) + " Flächenbindungen importiert")
+  
+ rs1.Close
+ rs2.Close
+ db1.Close
+ db2.Close
+
+ End If
+
+
+Exit Sub
+
+TableNotFound:
+
+ Exit Sub
+
+End Sub
+
+
+Sub ImportChargen(filename As String)
+
+Dim db1 As Database
+Dim rs1 As Recordset
+Dim db2 As Database
+Dim rs2 As Recordset
+Dim rs3 As Recordset
+Dim rs4 As Recordset
+Dim item1 As Integer
+
+Dim tempfilename1 As String
+Dim filename1 As String
+Dim tempfilename2 As String
+Dim filename2 As String
+Dim query1 As String
+Dim query2 As String
+Dim Lesejahr1 As Long
+Dim ZNR1 As Long
+Dim newCNR As Long
+Dim oldCNR As Long
+
+Dim endwhile1
+
+' get lesejahr1/znr1
+
+ Set db1 = Application.DBEngine.Workspaces(0).OpenDatabase(filename)
+ 
+ On Error GoTo TableNotFound
+ 
+ If IsNull(db1.TableDefs("xTChargen")) Then Exit Sub
+ 
+ Set rs1 = db1.OpenRecordset("xTChargen")
+ 
+ ' TChargen does not exist
+ If IsNull(rs1) Then Exit Sub
+ 
+  Lesejahr1 = rs1!Jahrgang
+  ZNR1 = rs1!ZNR
+  rs1.Close
+  db1.Close
+
+'TChargen
+ filename1 = "TChargen"
+ tempfilename1 = "xTChargen"
+
+ query1 = "SELECT * FROM xTChargen ORDER BY CNR"
+ 
+ DoCmd.Hourglass False
+If MsgBox("Sollen vorhandene Chargen der Zweigstelle " + Format(ZNR1) + " vom Lesejahr " + Format(Lesejahr1) + " eingelesen und überschrieben werden ?", vbYesNo) = vbYes Then
+  DoCmd.Hourglass True
+  Set db2 = CurrentDb
+  db2.Execute ("DELETE * FROM TChargen WHERE ZNR=" + Format(ZNR1) + " AND Year(Jahrgang)=" + Format(Lesejahr1) + ";")
+
+ If IsNull(DMax("CNR", "TChargen")) Then
+  newCNR = 0
+ Else
+  newCNR = DMax("CNR", "TChargen")
+ End If
+ 
+ Set db1 = Application.DBEngine.Workspaces(0).OpenDatabase(filename)
+ Set db2 = CurrentDb
+ 
+ Set rs1 = db1.OpenRecordset(query1, dbOpenSnapshot)
+ Set rs2 = db2.OpenRecordset(filename1, dbOpenDynaset, dbAppendOnly)
+ 
+ While Not rs1.EOF
+ 
+  ' Insert TChargen
+  newCNR = newCNR + 1
+  rs2.AddNew
+
+  
+  For item1 = 0 To db1.TableDefs(tempfilename1).Fields.Count - 1
+   rs2(item1) = rs1(item1)
+  Next item1
+  
+  oldCNR = rs1!CNR
+  rs2!CNR = newCNR
+  rs2.Update
+
+  ' Change CNR in TLieferungen
+  Set rs3 = db2.OpenRecordset("SELECT * FROM TLieferungen WHERE CNR=" + Format(oldCNR))
+  While Not rs3.EOF
+   rs3.Edit
+   rs3("CNR") = newCNR
+   rs3.Update
+   rs3.MoveNext
+  Wend
+  rs3.Close
+  
+  rs1.MoveNext
+ Wend
+ 
+ DoCmd.Hourglass False
+ MsgBox (Format(rs1.recordcount) + " Chargen importiert")
+ DoCmd.Hourglass True
+
+ rs1.Close
+ rs2.Close
+ db1.Close
+ db2.Close
+ 
+
+End If
+
+Exit Sub
+
+TableNotFound:
+
+ Exit Sub
+
+End Sub
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+Sub ImportAll(filename As String)
+
+Dim db1 As Database
+Dim rs1 As Recordset
+Dim db2 As Database
+Dim rs2 As Recordset
+Dim rs3 As Recordset
+Dim rs4 As Recordset
+Dim item1 As Integer
+
+Dim tempfilename1 As String
+Dim filename1 As String
+Dim tempfilename2 As String
+Dim filename2 As String
+Dim query1 As String
+Dim query2 As String
+Dim Lesejahr1 As Long
+Dim ZNR1 As Long
+Dim newLINR As Long
+Dim oldLINR As Long
+Dim newFBNR As Long
+
+Dim endwhile1
+
+' get lesejahr1/znr1
+
+ Set db1 = Application.DBEngine.Workspaces(0).OpenDatabase(filename)
+ Set rs1 = db1.OpenRecordset("xTLieferungen")
+ If IsNull(rs1) Then
+ Else
+  Lesejahr1 = year(rs1!Datum)
+  ZNR1 = rs1!ZNR
+  rs1.Close
+  db1.Close
+ End If
+
+'TLieferungen
+ filename1 = "TLieferungen"
+ tempfilename1 = "xTLieferungen"
+ tempfilename2 = "xTLieferungAbschlag"
+ filename2 = "TLieferungAbschlag"
+
+ query1 = "SELECT * FROM xTLieferungen ORDER BY LINR"
+ query2 = "SELECT * FROM xTLieferungAbschlag ORDER BY LINR"
+ 
+ DoCmd.Hourglass False
+ 
+If MsgBox("Sollen vorhandene Lieferungen der Zweigstelle " + Format(ZNR1) + " vom Lesejahr " + Format(Lesejahr1) + " eingelesen und überschrieben werden ?", vbYesNo) = vbYes Then
+  DoCmd.Hourglass True
+  Set db2 = CurrentDb
+  db2.Execute ("DELETE TLieferungAbschlag.* FROM TLieferungAbschlag RIGHT JOIN TLieferungen ON TLieferungAbschlag.LINR = TLieferungen.LINR WHERE ZNR=" + Format(ZNR1) + " AND Year(Datum)=" + Format(Lesejahr1) + ";")
+  db2.Execute ("DELETE * FROM TLieferungen WHERE ZNR=" + Format(ZNR1) + " AND Year(Datum)=" + Format(Lesejahr1) + ";")
+
+
+ 
+ newLINR = DMax("LINR", "TLieferungen")
+ 
+ Set db1 = Application.DBEngine.Workspaces(0).OpenDatabase(filename)
+ Set db2 = CurrentDb
+ 
+ Set rs1 = db1.OpenRecordset(query1, dbOpenSnapshot)
+ Set rs2 = db2.OpenRecordset(filename1, dbOpenDynaset, dbAppendOnly)
+ Set rs3 = db1.OpenRecordset(query2, dbOpenSnapshot)
+ Set rs4 = db2.OpenRecordset(filename2, dbOpenDynaset, dbAppendOnly)
+
+ While Not rs1.EOF
+ 
+  ' Insert TLieferungen
+  newLINR = newLINR + 1
+  rs2.AddNew
+
+  
+  For item1 = 0 To db1.TableDefs(tempfilename1).Fields.Count - 1
+   rs2(item1) = rs1(item1)
+  Next item1
+  
+  oldLINR = rs1!LINR
+  rs2!LINR = newLINR
+  rs2.Update
+
+
+  ' Insert TLieferungAbschlag and substitute new LINR
+
+  endwhile1 = 0
+  While endwhile1 = 0
+   If rs3.EOF Then
+    endwhile1 = 1
+   Else
+    If rs3!LINR >= oldLINR Then
+     endwhile1 = 1
+    Else
+     rs3.MoveNext
+    End If
+   End If
+
+  Wend
+  
+  endwhile1 = 0
+  While endwhile1 = 0
+   If rs3.EOF Then
+    endwhile1 = 1
+   Else
+    If rs3!LINR = oldLINR Then
+    
+     rs4.AddNew
+     For item1 = 0 To db1.TableDefs(tempfilename2).Fields.Count - 1
+      rs4(item1) = rs3(item1)
+     Next item1
+   
+     rs4!LINR = newLINR
+     rs4.Update
+     rs3.MoveNext
+
+    Else
+     endwhile1 = 1
+    End If
+   End If
+   
+  Wend
+  
+  rs1.MoveNext
+ Wend
+ 
+ DoCmd.Hourglass False
+ MsgBox (Format(rs1.recordcount) + " Lieferungen importiert")
+ DoCmd.Hourglass True
+
+ rs1.Close
+ rs2.Close
+ rs3.Close
+ rs4.Close
+ db1.Close
+ db2.Close
+ 
+
+End If
+
+
+
+
+'TMitglieder
+ filename1 = "TMitglieder"
+ tempfilename1 = "xTMitglieder"
+ tempfilename2 = "xTFlaechenbindungen"
+ filename2 = "TFlaechenbindungen"
+
+ query1 = "SELECT * FROM xTMitglieder ORDER BY MGNR"
+ query2 = "SELECT * FROM xTFlaechenbindungen ORDER BY MGNR"
+ 
+ DoCmd.Hourglass False
+ 
+ If MsgBox("Sollen vorhandene Mitglieder der Zweigstelle " + Format(ZNR1) + " eingelesen und überschrieben werden ?", vbYesNo) = vbYes Then
+  
+  DoCmd.Hourglass True
+  Set db2 = CurrentDb
+  db2.Execute ("DELETE TFlaechenbindungen.* FROM TFlaechenbindungen RIGHT JOIN TMitglieder ON TFlaechenbindungen.MGNR = TMitglieder.MGNR WHERE ZNR=" + Format(ZNR1) + ";")
+  db2.Execute ("DELETE * FROM TMitglieder WHERE ZNR=" + Format(ZNR1) + ";")
+  
+
+ 
+ Set db1 = Application.DBEngine.Workspaces(0).OpenDatabase(filename)
+ Set db2 = CurrentDb
+ 
+ Set rs1 = db1.OpenRecordset(tempfilename1)
+ Set rs2 = db2.OpenRecordset(filename1)
+
+ While Not rs1.EOF
+  ' Insert TMitglieder
+  rs2.AddNew
+  
+  For item1 = 0 To db1.TableDefs(tempfilename1).Fields.Count - 1
+   rs2(item1) = rs1(item1)
+  Next item1
+  rs2.Update
+  rs1.MoveNext
+ Wend
+ 
+ DoCmd.Hourglass False
+ MsgBox (Format(rs1.recordcount) + " Mitglieder importiert")
+ DoCmd.Hourglass True
+ 
+ rs1.Close
+ rs2.Close
+ db1.Close
+ db2.Close
+
+
+ Set db1 = Application.DBEngine.Workspaces(0).OpenDatabase(filename)
+ Set db2 = CurrentDb
+ 
+ Set rs1 = db1.OpenRecordset(tempfilename2)
+ Set rs2 = db2.OpenRecordset(filename2)
+
+ newFBNR = DMax("FBNR", "TFlaechenbindungen")
+ While Not rs1.EOF
+  ' Insert TFlaechenbindungen
+  newFBNR = newFBNR + 1
+  rs2.AddNew
+  
+  For item1 = 0 To db1.TableDefs(tempfilename2).Fields.Count - 1
+   rs2(item1) = rs1(item1)
+  Next item1
+  rs2!FBNR = newFBNR
+  rs2.Update
+  rs1.MoveNext
+ Wend
+ DoCmd.Hourglass False
+ MsgBox (Format(rs1.recordcount) + " Flächenbindungen importiert")
+  
+ rs1.Close
+ rs2.Close
+ db1.Close
+ db2.Close
+
+ End If
+ 
+ 
+ 
+End Sub
+
+Private Sub Form_Open(Cancel As Integer)
+
+Dim filename
+
+filename = GetParameter("ImportPfad")
+
+If Len(filename) > 0 Then
+ TImportFile = filename
+End If
+
+End Sub

wgmaster/vba/Form_MLeseauswertung.frm

@@ -0,0 +1,342 @@
+
+Private Sub Babbrechen_Click()
+
+DoCmd.Close
+
+End Sub
+
+Private Sub BOk_Click()
+
+Dim filter1 As String
+
+filter1 = GetFilter(False)
+ 
+Select Case OListe
+
+Case 1:
+ DoCmd.OpenReport "BLieferjournal", acPreview, , filter1
+Case 2:
+ DoCmd.OpenReport "BSortenstatistik", acPreview, , filter1
+Case 3:
+ DoCmd.OpenReport "BSortenstatistikAttribute", acPreview, , filter1
+Case 4:
+ DoCmd.OpenReport "BQualitätsstatistik", acPreview, , filter1
+Case 5:
+ DoCmd.OpenReport "BQualitätsstatistikRotWeiss", acPreview, , filter1
+Case 6:
+ DoCmd.OpenReport "BLieferstatistikProOrt", acPreview, , filter1
+
+End Select
+
+
+End Sub
+
+Private Sub BTagWeiter_Click()
+
+TVon = TVon + 1
+TBis = TBis + 1
+RefreshAll
+
+End Sub
+
+Private Sub BTagZurueck_Click()
+
+TVon = TVon - 1
+TBis = TBis - 1
+RefreshAll
+
+End Sub
+
+Private Sub Form_Activate()
+
+RefreshAll
+
+End Sub
+
+Private Sub Form_Open(Cancel As Integer)
+
+OListe = 1
+TVon = Date
+TBis = Date
+'TZNR = DFirst("ZNR", "TZweigstellen")
+
+End Sub
+
+
+Private Sub OListe_Click()
+
+RefreshAll
+
+
+End Sub
+
+Private Sub TBis_Exit(Cancel As Integer)
+
+RefreshAll
+
+End Sub
+
+Private Sub TFilter_Click()
+
+RefreshAll
+
+End Sub
+
+Private Sub TFilter_Exit(Cancel As Integer)
+RefreshAll
+
+End Sub
+
+Private Sub TFilterIn_Click()
+RefreshAll
+
+End Sub
+
+Private Sub TFilterIn_Exit(Cancel As Integer)
+RefreshAll
+
+End Sub
+
+Private Sub TVon_Exit(Cancel As Integer)
+
+RefreshAll
+
+End Sub
+
+
+Function GetFilter(optionFullMGNR As Boolean)
+
+Dim filter1 As String
+Dim hk As String
+
+If IsNull(TZNR) Then
+ filter1 = ""
+Else
+ filter1 = "TLieferungen.ZNR=" + Format(Forms!MLeseauswertung!TZNR) + " AND "
+End If
+
+filter1 = filter1 + "[Datum]>=Datevalue('" + Format([TVon], "dd.mm.yyyy") + "') AND [Datum]<=Datevalue('" + Format([TBis], "dd.mm.yyyy") + "')"
+'MsgBox (filter1)
+
+filter1 = filter1 + BuildMGNRIn(optionFullMGNR)
+'On Error GoTo error
+'If Not IsNull(TFilter) And TFilter <> "" Then
+' If TFilterIn = "MGNR" Then
+'  hk = ""
+'  If CLng(TFilter) <= 0 Then TFilter = ""
+' Else
+'  hk = "'"
+' End If
+' filter1 = filter1 + " AND " + TFilterIn + "=" + hk + Format(TFilter) + hk
+'End If
+
+'error:
+ GetFilter = filter1
+
+
+End Function
+
+Sub RefreshAll()
+
+
+Dim where2, where3
+
+
+'If TZNR.ListIndex >= 0 Then
+'where2 = " AND [TLieferungen].[ZNR]=[Formulare]![MLeseauswertung].[TZNR] "
+'Else
+'where2 = ""
+'End If
+
+Select Case OListe
+
+Case 1: ' alle lieferungen
+  where2 = GetFilter(True)
+  LLieferungen.RowSource = "SELECT TLieferungen.Lieferscheinnummer AS Lieferscheinnr, TLieferungen.MGNR, IIf(IsNull([Nachname]),'',[Nachname])+' '+IIf(IsNull([Vorname]),'',[Vorname]) AS Name, UCase([SNR]) AS Sorte, Oechsle, Gewicht FROM TMitglieder INNER JOIN TLieferungen ON TMitglieder.MGNR = TLieferungen.MGNR WHERE " + where2 + " ORDER BY TLieferungen.LINR;"
+  LLieferungen.ColumnCount = 6
+  LLieferungen.ColumnWidths = "3cm;1 cm;5,2 cm;1cm;1,5cm;1,5cm"
+  BOk.Visible = True
+  
+Case 2: ' sorten zusammen
+  where2 = GetFilter(False)
+  LLieferungen.RowSource = "SELECT TSorten.Bezeichnung AS Sorte, Format(Sum([Gewicht]*[Oechsle])/Sum([Gewicht]),'0,0') AS Oechsle1, Format(Sum(TLieferungen.Gewicht),'#######') AS Gewicht1 FROM TSorten INNER JOIN TLieferungen ON TSorten.SNR = TLieferungen.SNR WHERE " + where2 + " GROUP BY TSorten.typ,TSorten.Bezeichnung ORDER By TSorten.typ, TSorten.Bezeichnung"
+  'LLieferungen.RowSource = "SELECT TSorten.Bezeichnung AS Sorte, Format(Sum([Gewicht]*[Oechsle])/Sum([Gewicht]),'0,0') AS Oechsle1, Format(Sum(TLieferungen.Gewicht),'#######') AS Gewicht1 FROM TSorten INNER JOIN (TMitglieder INNER JOIN TLieferungen ON TMitglieder.MGNR = TLieferungen.MGNR) ON TSorten.SNR = TLieferungen.SNR WHERE " + where2 + " GROUP BY TSorten.Bezeichnung;"
+  LLieferungen.ColumnCount = 3
+  LLieferungen.ColumnWidths = "9cm;1,5cm;1,5cm"
+  BOk.Visible = True
+
+Case 3: ' sorten&attribute zusammen
+  where2 = GetFilter(False)
+
+  LLieferungen.RowSource = "SELECT TSorten.Bezeichnung AS Sorte, TSortenAttribute.Attribut, Format(Sum([Gewicht]*[Oechsle])/Sum([Gewicht]),'#,#00') AS Oechsle1, Format(Sum(TLieferungen.Gewicht),'#') AS Gewicht1 FROM (TSorten INNER JOIN TLieferungen ON TSorten.SNR = TLieferungen.SNR) LEFT JOIN TSortenAttribute ON TLieferungen.SANR = TSortenAttribute.SANR WHERE (((" + where2 + ") <> False)) GROUP BY TSorten.typ,TSorten.Bezeichnung, TSortenAttribute.Attribut ORDER By TSorten.typ, TSorten.Bezeichnung,TSortenAttribute.Attribut"
+    'LLieferungen.RowSource = "SELECT TSorten.Bezeichnung AS Sorte, Format(Sum([Gewicht]*[Oechsle])/Sum([Gewicht]),'0,0') AS Oechsle1, Format(Sum(TLieferungen.Gewicht),'#######') AS Gewicht1 FROM TSorten INNER JOIN (TMitglieder INNER JOIN TLieferungen ON TMitglieder.MGNR = TLieferungen.MGNR) ON TSorten.SNR = TLieferungen.SNR WHERE " + where2 + " GROUP BY TSorten.Bezeichnung;"
+  LLieferungen.ColumnCount = 4
+  LLieferungen.ColumnWidths = "7cm;2cm;1,5cm;1,5cm"
+  BOk.Visible = True
+
+Case 4: ' qualitäten zusammen
+  where2 = GetFilter(False)
+  LLieferungen.RowSource = "SELECT TQualitaetsstufen.Bezeichnung, Format(Sum([Gewicht]*[Oechsle])/Sum(Gewicht),'#,#00') AS Oechsle1, Sum(TLieferungen.Gewicht) AS Gewicht1, TLieferungen.QSNR FROM (TSorten INNER JOIN TLieferungen ON TSorten.SNR = TLieferungen.SNR) INNER JOIN TQualitaetsstufen ON TLieferungen.QSNR = TQualitaetsstufen.QSNR WHERE " + where2 + " GROUP BY TQualitaetsstufen.Bezeichnung, TLieferungen.QSNR ORDER BY TLieferungen.QSNR;"
+  'LLieferungen.RowSource = "SELECT TQualitaetsstufen.Bezeichnung, Format(Sum([Gewicht]*[Oechsle])/Sum(Gewicht),'#,#00') AS Oechsle1, Sum(TLieferungen.Gewicht) AS Gewicht1, TLieferungen.QSNR FROM (TSorten INNER JOIN (TMitglieder INNER JOIN TLieferungen ON TMitglieder.MGNR = TLieferungen.MGNR) ON TSorten.SNR = TLieferungen.SNR) INNER JOIN TQualitaetsstufen ON TLieferungen.QSNR = TQualitaetsstufen.QSNR WHERE " + where2 + " GROUP BY TQualitaetsstufen.Bezeichnung, TLieferungen.QSNR ORDER BY TLieferungen.QSNR;"
+  LLieferungen.ColumnCount = 3
+  LLieferungen.ColumnWidths = "9cm;1,5 cm;1,5"
+  BOk.Visible = True
+  
+Case 5: ' qualitäten zusammen, rot/weiß
+  where2 = GetFilter(False)
+  LLieferungen.RowSource = "SELECT TSorten.Typ, TQualitaetsstufen.Bezeichnung, Format(Sum([Gewicht]*[Oechsle])/Sum(Gewicht),'#,#00') AS Oechsle1, Sum(TLieferungen.Gewicht) AS Gewicht1, TLieferungen.QSNR FROM (TSorten INNER JOIN TLieferungen ON TSorten.SNR = TLieferungen.SNR) INNER JOIN TQualitaetsstufen ON TLieferungen.QSNR = TQualitaetsstufen.QSNR WHERE " + where2 + " GROUP BY TQualitaetsstufen.Bezeichnung, TSorten.Typ, TLieferungen.QSNR ORDER BY TSorten.Typ, TLieferungen.QSNR"
+  LLieferungen.ColumnCount = 4
+  LLieferungen.ColumnWidths = "3 cm;6 cm;1,5 cm;1,5"
+  BOk.Visible = True
+    
+Case 6: ' lieferstatistik pro ort
+  where2 = GetFilter(False)
+  
+  '"SELECT TMitglieder.Ort, Sum(TLieferungen.Gewicht) AS SummeGewicht FROM TMitglieder INNER JOIN TLieferungen ON TMitglieder.MGNR = TLieferungen.MGNR WHERE " + where2 + " GROUP BY TMitglieder.Ort ORDER BY TMitglieder.Ort"
+
+  
+  LLieferungen.RowSource = "SELECT TMitglieder.Ort, Sum(TLieferungen.Gewicht) AS SummeGewicht, Format(Avg(TLieferungen.Oechsle),'0.0') AS MittelwertOechsle FROM TMitglieder INNER JOIN TLieferungen ON TMitglieder.MGNR = TLieferungen.MGNR WHERE " + where2 + " GROUP BY TMitglieder.Ort ORDER BY TMitglieder.Ort"
+  LLieferungen.ColumnCount = 3
+  LLieferungen.ColumnWidths = "4 cm;2 cm; 3 cm"
+  BOk.Visible = True
+    
+    
+    
+End Select
+
+'CalculateSums (where2)
+TGesamtgewicht.Requery
+TQualitaet.Requery
+LLieferungen.Requery
+
+RefreshBeschreibung
+
+End Sub
+
+
+Sub RefreshBeschreibung()
+
+Dim Beschreibung As String
+
+
+If Not IsNull(TVon) And Not IsNull(TBis) Then
+ If TVon = TBis Then
+  Beschreibung = Beschreibung + Format(TVon, "dd.mm.yyyy") + ", "
+ Else
+  Beschreibung = Beschreibung + Format(TVon, "dd.mm.yyyy") + "-" + Format(TBis, "dd.mm.yyyy") + ", "
+ End If
+Else
+    If Not IsNull(TVon) Then
+     Beschreibung = Beschreibung + "ab " + Format(TVon, "dd.mm.yyyy") + ", "
+    End If
+    If Not IsNull(TBis) Then
+     Beschreibung = Beschreibung + "bis " + Format(TBis, "dd.mm.yyyy") + ", "
+    End If
+ 
+End If
+
+If Not IsNull(TZNR) Then
+ Beschreibung = Beschreibung + "Zweigstelle=" + DFirst("Name", "TZweigstellen", "ZNR=" + Format(TZNR)) + ", "
+End If
+
+If Not IsNull(TFilter) And Not IsNull(TFilterIn) Then
+ Beschreibung = Beschreibung + TFilterIn + "=" + TFilter + ", "
+End If
+
+Beschreibung = Left(Beschreibung, Len(Beschreibung) - 2)
+
+TBeschreibung = Beschreibung
+
+End Sub
+
+
+Private Sub TZNR_Click()
+
+RefreshAll
+
+End Sub
+
+Private Sub TZNR_Exit(Cancel As Integer)
+
+RefreshAll
+
+End Sub
+
+Sub CalculateSums(where1 As String)
+
+Dim db1 As Database
+Dim rs1 As Recordset
+Dim gesamtgewicht As Double
+Dim qualitaet As Double
+
+Set db1 = CurrentDb
+If where1 <> "" Then where1 = " WHERE " + where1
+Set rs1 = db1.OpenRecordset("SELECT * FROM TMitglieder INNER JOIN TLieferungen ON TMitglieder.MGNR = TLieferungen.MGNR " + where1)
+While Not rs1.EOF
+ If Not IsNull(rs1!Gewicht) Then
+  gesamtgewicht = gesamtgewicht + rs1!Gewicht
+  If Not IsNull(rs1!Oechsle) Then
+   qualitaet = qualitaet + rs1!Gewicht * rs1!Oechsle
+  End If
+ End If
+ rs1.MoveNext
+Wend
+rs1.Close
+
+TGesamtgewicht = gesamtgewicht
+If gesamtgewicht > 0 Then
+ TQualitaet = Runden(qualitaet / gesamtgewicht, 1)
+Else
+ TQualitaet = ""
+End If
+
+End Sub
+
+
+Function BuildMGNRIn(optionFullMGNR As Boolean) As String
+
+Dim db1 As Database
+Dim rs1 As Recordset
+Dim mgnrinstr As String
+Dim filter2 As String
+
+Set db1 = CurrentDb
+
+mgnrinstr = ""
+On Error GoTo endbuild
+If Not IsNull(TFilter) And TFilter <> "" Then
+
+     If TFilterIn = "MGNR" Then
+      If CLng(TFilter) > 0 Then
+        mgnrinstr = " AND MGNR = " + Format(TFilter)
+        If optionFullMGNR Then
+         mgnrinstr = " AND TLieferungen.MGNR = " + Format(TFilter)
+        Else
+         mgnrinstr = " AND MGNR = " + Format(TFilter)
+        End If
+        GoTo endbuild
+       End If
+     End If
+     filter2 = " WHERE " + TFilterIn + "='" + Format(TFilter) + "'"
+    
+    
+    Set rs1 = db1.OpenRecordset("SELECT DISTINCT TMitglieder.MGNR FROM TMitglieder INNER JOIN TLieferungen ON TMitglieder.MGNR = TLieferungen.MGNR " + filter2 + " ORDER BY TMitglieder.MGNR")
+    If optionFullMGNR Then
+     mgnrinstr = " AND TLieferungen.MGNR IN (-1,"
+    Else
+     mgnrinstr = " AND MGNR IN (-1,"
+    End If
+    While Not rs1.EOF
+     mgnrinstr = mgnrinstr + Format(rs1!MGNR) + ","
+     rs1.MoveNext
+    Wend
+    rs1.Close
+    mgnrinstr = Left(mgnrinstr, Len(mgnrinstr) - 1) + ") "
+    
+End If
+
+endbuild:
+'MsgBox (mgnrinstr)
+BuildMGNRIn = mgnrinstr
+
+End Function

wgmaster/vba/Form_MLieferscheinBereinigung.frm

@@ -0,0 +1,111 @@
+
+Dim f_linr(0 To 1000) As Long
+Dim f_count As Long
+
+Private Sub BLöschen_Click()
+
+Dim i As Integer
+If MsgBox("Wollen Sie die ausgewählten Lieferungen wirklich löschen?", vbYesNo) = vbYes Then
+
+    For i = 0 To LLieferungen.ListCount - 1
+     If LLieferungen.Selected(i) Then
+      If DFirst("Gewicht", "TLieferungen", "LINR=" + Format(LLieferungen.ItemData(i))) > 0 Then
+        If MsgBox("Die Lieferung mit LINR=" + Format(LLieferungen.ItemData(i)) + " enthält ein Gewicht > 0. Wollen Sie sie wirklich löschen ?", vbYesNo) = vbYes Then
+         'Löschen
+         LieferscheinLöschen (LLieferungen.ItemData(i))
+        End If
+      Else
+        'Löschen
+         LieferscheinLöschen (LLieferungen.ItemData(i))
+      End If
+     End If
+    Next i
+    LLieferungen.Requery
+End If
+
+End Sub
+
+Sub LieferscheinLöschen(LINR1 As Long)
+
+Dim db1 As Database
+
+Set db1 = CurrentDb
+db1.Execute ("DELETE * FROM TLieferungAbschlag WHERE LINR=" + Format(LINR1) + ";")
+db1.Execute ("DELETE * FROM TLieferungen WHERE LINR=" + Format(LINR1) + ";")
+
+End Sub
+
+Private Sub BWeiter_Click()
+
+TLesejahr = TLesejahr - 1
+BuildList
+
+End Sub
+
+Private Sub BZurueck_Click()
+
+TLesejahr = TLesejahr + 1
+BuildList
+
+End Sub
+
+Private Sub Form_Open(Cancel As Integer)
+
+If Month(Date) > 7 Then
+ TLesejahr = year(Date)
+Else
+ TLesejahr = year(Date) - 1
+End If
+BuildList
+
+End Sub
+
+Private Sub LLieferungen_DblClick(Cancel As Integer)
+
+If LLieferungen.ListIndex >= 0 Then
+ DoCmd.OpenForm "FLieferungen", , , "LINR=" + Format(LLieferungen.ItemData(LLieferungen.ListIndex + 1))
+End If
+
+End Sub
+
+Private Sub TLesejahr_Exit(Cancel As Integer)
+
+BuildList
+
+End Sub
+
+
+Sub BuildList()
+
+Dim db1 As Database
+Dim rs1 As Recordset
+Dim where2 As String
+Dim query1 As String
+Dim where1 As String
+Dim order1 As String
+Dim order2 As String
+
+query1 = "SELECT LINR, Lieferscheinnummer, TLieferungen.Datum, TLieferungen.Uhrzeit, TLieferungen.SNR, TSorten.Bezeichnung, TLieferungen.MGNR, TMitglieder.Nachname, TMitglieder.Vorname, TLieferungen.Gewicht, TLieferungen.Oechsle, TLieferungen.Storniert FROM TMitglieder RIGHT JOIN (TSorten RIGHT JOIN TLieferungen ON TSorten.SNR = TLieferungen.SNR) ON TMitglieder.MGNR = TLieferungen.MGNR"
+order2 = " ORDER BY LINR"
+f_count = 0
+where2 = "AND Year(TLieferungen.Datum)=" + Format(TLesejahr)
+Set db1 = CurrentDb
+Set rs1 = db1.OpenRecordset("SELECT LINR FROM TMitglieder RIGHT JOIN (TSorten RIGHT JOIN TLieferungen ON TSorten.SNR = TLieferungen.SNR) ON TMitglieder.MGNR = TLieferungen.MGNR WHERE (Lieferscheinnummer Is Null Or  Nachname is null or Bezeichnung is null or Oechsle is null or Gewicht is null) " + where2 + order2)
+While Not rs1.EOF
+ f_linr(f_count) = rs1!LINR
+ f_count = f_count + 1
+ rs1.MoveNext
+Wend
+rs1.Close
+
+where1 = " WHERE LINR IN (-1,"
+For i = 0 To f_count - 1
+ where1 = where1 + Format(f_linr(i)) + ","
+Next i
+where1 = Left(where1, Len(where1) - 1) + ")"
+order1 = " ORDER BY LINR"
+
+LLieferungen.RowSource = query1 + where1 + order1
+LLieferungen.Requery
+
+End Sub

wgmaster/vba/Form_MLieferungAuswahl.frm

@@ -0,0 +1,148 @@
+
+Dim lastLINR
+
+Private Sub BBearbeiten_Click()
+
+If LLieferungen >= 0 Then
+ lastLINR = LLieferungen
+ DoCmd.OpenForm "FLieferungen", acNormal, , "LINR=" + Format(LLieferungen)
+End If
+
+End Sub
+
+Private Sub BChargenZuordnen_Click()
+
+If MsgBox("Wollen Sie alle Lieferungen des ausgewählten Lesejahres und der ausgewählten Zweigstelle automatisch eine Charge zuordnen? (Es werden nur Chargen zugeordnet, wenn nicht bereits eine Charge zugeordnet ist)", vbYesNo) = vbYes Then
+ If TZNR > 0 Then
+  ChargenZuLieferungenZuordnen TLesejahr, TZNR
+ Else
+  ChargenZuLieferungenZuordnen (TLesejahr)
+ End If
+End If
+LLieferungen.Requery
+
+End Sub
+
+Private Sub BJahrWeiter_Click()
+
+If Not IsNull(TLesejahr) Then
+ TLesejahr = TLesejahr + 1
+ RefreshAll
+End If
+
+End Sub
+
+Private Sub BJahrZurueck_Click()
+
+If Not IsNull(TLesejahr) Then
+ TLesejahr = TLesejahr - 1
+ RefreshAll
+End If
+
+End Sub
+
+Private Sub Form_Activate()
+
+RefreshAll
+
+End Sub
+
+Private Sub Form_Load()
+ 
+
+If Month(Date) < 8 Then
+ TLesejahr = year(Date) - 1
+Else
+ TLesejahr = year(Date)
+End If
+
+TSortierung = "Datum, Uhrzeit"
+
+lastLINR = -1
+
+RefreshAll
+
+
+
+End Sub
+
+Private Sub LLieferungen_DblClick(Cancel As Integer)
+
+lastLINR = LLieferungen
+
+DoCmd.OpenForm "FLieferungen", acNormal, , "LINR=" + Format(LLieferungen)
+
+
+End Sub
+
+Private Sub TLesejahr_Exit(Cancel As Integer)
+
+RefreshAll
+
+End Sub
+
+Function GetFilter() As String
+
+Dim filter1
+
+filter1 = "Year(Datum)=" + Format(TLesejahr)
+
+If Not IsNull(TZNR) Then
+  filter1 = filter1 + " AND TLieferungen.ZNR=" + TZNR
+End If
+
+GetFilter = filter1
+
+End Function
+
+Function GetOrder() As String
+
+If Not IsNull(TSortierung) Then
+ GetOrder = " ORDER BY " + TSortierung
+Else
+ GetOrder = ""
+End If
+End Function
+
+
+Sub RefreshAll()
+
+Dim filter1
+Dim query1
+
+'query1 = "SELECT TLieferungen.LINR, TLieferungen.Lieferscheinnummer AS Lieferscheinnr, TLieferungen.Datum, Format(TLieferungen.Uhrzeit,'HH:MM') as Zeit, TMitglieder.MGNR, [Nachname]+' '+IIf(IsNull([Vorname]),'',[Vorname]) AS Mitglied, TSorten.Bezeichnung AS Sorte, TLieferungen.Gewicht, TLieferungen.Oechsle, IIf(Storniert=True,'STORNIERT',Left(TLieferungen.Anmerkung,20)) AS Info FROM TSorten INNER JOIN (TMitglieder INNER JOIN TLieferungen ON TMitglieder.MGNR = TLieferungen.MGNR) ON TSorten.SNR = TLieferungen.SNR"
+'query1 = "SELECT TLieferungen.LINR, TLieferungen.Lieferscheinnummer AS Lieferscheinnr, TLieferungen.Datum, Format(TLieferungen.Uhrzeit,'hh:nn') AS Zeit, TMitglieder.MGNR, [Nachname]+' '+IIf(IsNull([Vorname]),'',[Vorname]) AS Mitglied, TSorten.Bezeichnung AS Sorte, TSortenAttribute.Attribut, TLieferungen.Gewicht As kg, TLieferungen.Oechsle As Oe, IIf(Storniert=True,'STORNIERT',Left(TLieferungen.Anmerkung,20)) AS Info FROM (TSorten INNER JOIN (TMitglieder INNER JOIN TLieferungen ON TMitglieder.MGNR = TLieferungen.MGNR) ON TSorten.SNR = TLieferungen.SNR) LEFT JOIN TSortenAttribute ON TLieferungen.SANR = TSortenAttribute.SANR"
+query1 = "SELECT TLieferungen.LINR, TLieferungen.Lieferscheinnummer AS Lieferscheinnr, TLieferungen.Datum, Format(TLieferungen.Uhrzeit,'hh:nn') AS Zeit, TMitglieder.MGNR, [Nachname]+' '+IIf(IsNull([Vorname]),'',[Vorname]) AS Mitglied, TSorten.Bezeichnung AS Sorte, TSortenAttribute.Attribut, TLieferungen.Gewicht AS kg, TLieferungen.Oechsle AS Oe, IIf(Storniert=True,'STORNIERT',Left(TLieferungen.Anmerkung,20)) AS Info, TChargen.Chargennummer FROM ((TSorten INNER JOIN (TMitglieder INNER JOIN TLieferungen ON TMitglieder.MGNR = TLieferungen.MGNR) ON TSorten.SNR = TLieferungen.SNR) LEFT JOIN TSortenAttribute ON TLieferungen.SANR = TSortenAttribute.SANR) LEFT JOIN TChargen ON TLieferungen.CNR = TChargen.CNR"
+
+
+filter1 = GetFilter
+query1 = query1 + " WHERE " + filter1 + GetOrder
+'MsgBox (query1)
+LLieferungen.RowSource = query1
+LLieferungen.Requery
+
+LLieferungen.SetFocus
+
+If lastLINR = -1 And LLieferungen.ListCount > 0 Then
+'MsgBox (LLieferungen.ItemData(1))
+ LLieferungen = LLieferungen.ItemData(1)
+End If
+
+If lastLINR >= 0 Then
+ LLieferungen = lastLINR
+End If
+
+
+End Sub
+
+Private Sub TSortierung_Change()
+
+RefreshAll
+
+End Sub
+
+Private Sub TZNR_Change()
+
+RefreshAll
+
+End Sub

wgmaster/vba/Form_MLieferungSuchen.frm

@@ -0,0 +1,78 @@
+
+Private Sub Babbrechen_Click()
+
+DoCmd.Close
+
+End Sub
+
+Private Sub BOk_Click()
+
+Dim mgnr1
+Dim lieferscheinnummer1
+Dim Lesejahr1
+
+mgnr1 = TMGNR.Value
+lieferscheinnummer1 = TLieferscheinnummer.Value
+Lesejahr1 = TLesejahr.Value
+
+
+If OAuswahl = 1 Then
+DoCmd.Close
+
+Forms!FLieferungen!TMGNR.SetFocus
+Forms!FLieferungen.filter = "Year(Datum)=" + Format(Lesejahr1)
+DoCmd.FindRecord mgnr1, acEntire, , , , acCurrent
+
+Else
+ If OAuswahl = 2 Then
+  DoCmd.Close
+  Forms!FLieferungen!TLieferscheinnummer.SetFocus
+  DoCmd.FindRecord lieferscheinnummer1, acEntire, , , , acCurrent
+
+ End If
+
+End If
+
+
+
+End Sub
+
+Private Sub Form_Open(Cancel As Integer)
+
+OAuswahl = 2
+
+If Month(Date) < 9 Then
+ TLesejahr = year(Date) - 1
+Else
+ TLesejahr = year(Date)
+End If
+
+End Sub
+
+Private Sub TLieferscheinnummer_Change()
+
+OAuswahl.Value = 2
+
+End Sub
+
+Private Sub TMGNR_Change()
+
+OAuswahl.Value = 1
+
+End Sub
+
+Private Sub TMGNR_Exit(Cancel As Integer)
+TMitglied = TMGNR
+End Sub
+
+Private Sub TMitglied_Change()
+
+TMGNR = TMitglied
+OAuswahl.Value = 1
+
+
+End Sub
+
+Private Sub TMitglied_Exit(Cancel As Integer)
+TMGNR = TMitglied
+End Sub

wgmaster/vba/Form_MMandantenauswahl.frm

@@ -0,0 +1,471 @@
+Private Sub BAendern_Click()
+
+Dim str1 As String, str2 As String, oldpath As String
+
+If Not IsNull(LMandanten) And LMandanten >= 0 Then
+
+ str1 = ""
+ While str1 = ""
+ str1 = InputBox("Geben Sie bitte die Mandantenbezeichnung ein:", "Mandanten bearbeiten", DMax("[Bezeichnung]", "Mandanten", "[MANR]=" + Format(LMandanten)))
+ Wend
+
+ str2 = ""
+ While str2 = ""
+ str2 = InputBox("Geben Sie bitte den Datenpfad ein:", "Mandanten bearbeiten", DMax("[Data]", "Mandanten", "[MANR]=" + Format(LMandanten)))
+ Wend
+ 
+ Dim db1 As Database
+ Dim rs1 As Recordset
+ 
+ Set db1 = CurrentDb
+ Set rs1 = db1.OpenRecordset("Mandanten")
+ 
+ While Not rs1.EOF And rs1!MANR <> CLng(LMandanten)
+  rs1.MoveNext
+ Wend
+ 
+ rs1.Edit
+ oldpath = rs1!Data
+ rs1!Bezeichnung = str1
+ rs1!Data = str2
+ rs1.Update
+ rs1.Close
+ 
+ LMandanten.Requery
+ 'If MsgBox("Wollen Sie die Daten kopieren", vbYesNo) = vbYes Then
+ '
+ ' If oldpath <> str2 Then
+ '  FileCopy oldpath, str2
+ ' End If
+ 'End If
+End If
+
+End Sub
+
+Private Sub BLoeschen_Click()
+
+If Not IsNull(LMandanten) And LMandanten >= 0 Then
+
+If MsgBox("Sind Sie sicher, daß Sie diesen Mandanten löschen wollen ?", vbYesNo) = vbYes Then
+
+  Dim db1 As Database
+  Dim rs1 As Recordset
+ 
+ Set db1 = CurrentDb
+ Set rs1 = db1.OpenRecordset("Mandanten")
+ 
+ While Not rs1.EOF And rs1!MANR <> CLng(LMandanten)
+  rs1.MoveNext
+ Wend
+ 
+ rs1.Delete
+ rs1.Close
+
+ LMandanten.Requery
+End If
+
+End If
+
+End Sub
+
+Private Sub BNeu_Click()
+
+Dim str1, str2 As String
+
+ str1 = ""
+ While str1 = ""
+ str1 = InputBox("Geben Sie bitte die Mandantenbezeichnung ein:", "Mandanten bearbeiten")
+ Wend
+ 
+ str2 = ""
+ While str2 = ""
+ str2 = InputBox("Geben Sie bitte den Datenpfad ein:", "Mandanten bearbeiten", AppPath + "WGDATEN.ACCDB")
+ Wend
+ 
+ Dim db1 As Database
+ Dim rs1 As Recordset
+ 
+ Set db1 = CurrentDb
+ Set rs1 = db1.OpenRecordset("Mandanten")
+
+ rs1.AddNew
+ rs1!Bezeichnung = str1
+ rs1!Data = str2
+ rs1.Update
+ rs1.Close
+
+ LMandanten.Requery
+ 
+ If InStr(str2, "\") > 0 Then
+  If MsgBox("Soll das Daten-Verzeichnis erstellt werden ?", vbYesNo) = vbYes Then
+   ' Verzeichnis erstellen
+   FileSystem.MkDir Mid(GetPathWithoutFilename(str2), 1, Len(GetPathWithoutFilename(str2)) - 1)
+  End If
+ End If
+ 
+ If MsgBox("Wollen Sie eine neue Daten-Datei anlegen ?", vbYesNo) = vbYes Then
+  FileCopy GetAppPath + "WGDATEN.ACCDB", str2
+ End If
+
+End Sub
+
+Private Sub BOk_Click()
+
+Weiter
+
+End Sub
+
+
+
+
+Private Sub BRücksichern_Click()
+
+
+Dim datapath1
+Dim apppath1
+Dim archname
+Dim archname1
+Dim archname2
+Dim cmdstr1
+
+Dim sicherungspfad1 As String
+
+
+
+If MsgBox("Sind Sie sicher, daß Sie sämtliche Daten von Diskette rücksichern wollen ? Alle aktuellen WG MASTER Daten auf der Festplatte gehen dabei verloren !!!", vbYesNo) = vbYes Then
+
+        If IsNull(GetParameter("SICHERUNGSPFAD")) Then
+          SetParameter "SICHERUNGSPFAD", "A:\"
+        End If
+        
+        sicherungspfad1 = GetParameter("SICHERUNGSPFAD")
+        
+        str1 = InputBox("Bitte geben Sie den Pfad ein, von wo WG MASTER rücksichern soll: ", "Sicherungspfad eingeben", sicherungspfad1)
+        If Not IsNull(str1) And str1 <> "" Then
+         sicherungspfad1 = str1
+          SetParameter "SICHERUNGSPFAD", sicherungspfad1
+        End If
+        
+        archname = "wgdata.arj"
+        archname2 = sicherungspfad1 + archname
+        
+        datapath1 = GetDataPath
+        apppath1 = GetAppPath
+        archname1 = GetPathWithoutFilename(GetDataPath) + archname
+        
+        On Error GoTo Error1
+        
+        If Not IsNull(datapath1) And Not IsNull(apppath1) Then
+        
+         
+        MsgBox ("Bitte Medium in Laufwerk " + sicherungspfad1 + " einlegen (Diskette, ZIP-Medium)")
+         
+         If Fileexist(Format(archname2)) = False Then
+          MsgBox "FEHLER: Sicherungsdatei nicht gefunden !", vbCritical
+          Exit Sub
+         Else
+          If Fileexist(Format(archname1)) Then FileSystem.Kill (archname1)
+          DoCmd.Hourglass True
+          FileCopy archname2, archname1
+          If Fileexist(Format(datapath1)) Then FileSystem.Kill (datapath1)
+        
+          FileSystem.ChDrive Left(GetDataPath, 1)
+          FileSystem.ChDir GetPathWithoutFilename(GetDataPath)
+          cmdstr1 = apppath1 + "arj.exe x -y " + archname1 + " " + GetPathWithoutFilename(GetDataPath) + " " + "WGDATEN.ACCDB"
+          'MsgBox (cmdstr1)
+          Shell cmdstr1, vbNormalFocus
+          FileSystem.ChDir apppath1
+         
+          DoCmd.Hourglass False
+          MsgBox ("Daten erfolgreich rückgesichert")
+         End If
+         
+        End If
+        
+        Exit Sub
+
+End If
+
+Error1:
+ MsgBox "FEHLER: Datenträger nicht bereit!", vbCritical
+ DoCmd.Hourglass False
+ Exit Sub
+
+
+
+End Sub
+
+Private Sub BSichern_Click()
+
+Dim datapath1
+Dim apppath1
+Dim archname
+Dim archname1
+Dim archname2
+Dim cmdstr1
+Dim sicherungspfad1 As String
+Dim str1
+
+If IsNull(GetParameter("SICHERUNGSPFAD")) Then
+  SetParameter "SICHERUNGSPFAD", "A:\"
+End If
+
+sicherungspfad1 = GetParameter("SICHERUNGSPFAD")
+
+str1 = InputBox("Bitte geben Sie den Pfad ein, wohin WG MASTER sichern soll: ", "Sicherungspfad eingeben", sicherungspfad1)
+If Not IsNull(str1) And str1 <> "" Then
+ sicherungspfad1 = str1
+  SetParameter "SICHERUNGSPFAD", sicherungspfad1
+End If
+
+
+archname = "wgdata.arj"
+archname2 = sicherungspfad1 + archname
+
+datapath1 = GetDataPath
+apppath1 = GetAppPath
+archname1 = GetPathWithoutFilename(GetDataPath) + archname
+
+'MsgBox (datapath1)
+'MsgBox (apppath1)
+'MsgBox (archname1)
+'MsgBox (archname2)
+
+On Error GoTo Error1
+
+If Not IsNull(datapath1) And Not IsNull(apppath1) Then
+ DoCmd.Hourglass True
+ 
+ 
+ If Fileexist(Format(archname1)) = True Then FileSystem.Kill (archname1)
+ 
+ FileSystem.ChDrive Left(GetDataPath, 1)
+ FileSystem.ChDir GetPathWithoutFilename(GetDataPath)
+ cmdstr1 = apppath1 + "arj.exe a " + archname1 + " " + "WGDATEN.ACCDB"
+ 'MsgBox (cmdstr1)
+ Shell cmdstr1, vbNormalFocus
+ FileSystem.ChDir apppath1
+ 
+ MsgBox ("Bitte Medium in Laufwerk " + sicherungspfad1 + " einlegen (Diskette, ZIP-Medium)")
+
+ If Fileexist(Format(archname2)) Then FileSystem.Kill (archname2)
+ 
+ FileCopy archname1, archname2
+ FileSystem.Kill archname1
+ If Fileexist(Format(archname1)) Then FileSystem.Kill (archname1)
+ 
+ DoCmd.Hourglass False
+ MsgBox ("Daten erfolgreich gesichert")
+End If
+
+Exit Sub
+
+Error1:
+ MsgBox "FEHLER: Datenträger nicht bereit!", vbCritical
+ DoCmd.Hourglass False
+ Exit Sub
+
+
+
+
+End Sub
+
+Private Sub Form_Close()
+
+'docmd.quit
+
+End Sub
+
+Private Sub Form_Open(Cancel As Integer)
+
+LMandanten.SetFocus
+If Not IsNull(LMandanten.ItemData(0)) Then LMandanten = LMandanten.ItemData(0)
+
+End Sub
+
+Private Sub LMandanten_DblClick(Cancel As Integer)
+
+Weiter
+
+End Sub
+
+Sub Weiter()
+
+If Not IsNull(LMandanten) And LMandanten >= 0 Then
+
+  Dim manr1 As Long
+  Dim Data As String
+  Dim datapath As String
+ 
+  DoCmd.Hourglass True
+ 
+  manr1 = LMandanten
+ 
+  Data = DMax("[Data]", "Mandanten", "MANR=" + Format(manr1))
+ 
+  'MsgBox (data)
+ 
+  If FileSystem.FileLen(Data) > 0 Then
+ 
+    datapath = GetPathWithoutFilename(Data)
+   
+  'MsgBox ("1")
+    
+    SetLinkTablePath "", Data
+  
+  
+  
+  
+    'Check runtime or full version
+    If UCase(Right(CurrentDb.Name, 1)) = "B" Then 'MDB or ACCDB
+      
+      
+      If manr1 <> GetLastMANR() Then
+          SetLastMANR (manr1)
+          SetReportControlProperty1 "", "BLogo", acImage, "Picture", datapath + "LOGO.BMP"
+      End If
+      
+      
+      'Vollupdate prüfen
+  'MsgBox ("2")
+      DoCmd.OpenForm "MHauptmenü", acDesign
+      
+      If Forms("MHauptmenü").XVersion2.Caption = "Vollupdate" Then
+        '1. Logo aktualisieren
+        
+  'MsgBox ("3")
+        SetReportControlProperty1 "", "BLogo", acImage, "Picture", datapath + "LOGO.BMP"
+      
+      
+       '2. SQL Statements ausführen
+        Dim db1 As Database
+        Dim cnt1 As Container
+        Dim doc1 As Document
+              
+         ' Current Database for SQL Statements
+        Dim db2 As Database
+        Dim rs1 As Recordset
+        
+        
+        Set db2 = Application.DBEngine.Workspaces(0).OpenDatabase(GetDataPath())
+        
+         Set db1 = CurrentDb
+          For Each cnt1 In db1.Containers
+           
+           If cnt1.Name = "Tables" Then
+            For Each doc1 In cnt1.Documents
+             If doc1.Name = "Update_SQLStatements" Then
+              Set rs1 = db1.OpenRecordset("Update_SQLStatements")
+              While Not rs1.EOF
+               'If MsgBox(rs1!Beschreibung + " ?", vbYesNo) = vbYes Then
+                On Error Resume Next
+                db2.Execute (rs1!SQLStatement)
+               'End If
+               rs1.MoveNext
+              Wend
+              rs1.Close
+              db1.Execute ("DROP Table Update_SQLStatements")
+             End If
+            Next doc1
+           End If
+            
+         Next cnt1
+         
+       '3. Übernahmeformular - Kommunikationsparameter einstellen
+       'DoCmd.OpenForm "FÜbernahme", acDesign
+    
+       'MsgBox (GetParameter("WAAGEPORTSETTINGS"))
+       'MsgBox (CLng(GetParameter("WAAGEPORT")))
+       'MsgBox (CLng(GetParameter("STEUERUNGPORT")))
+       
+       'Forms!FÜbernahme!XComm.Settings = GetParameter("WAAGEPORTSETTINGS")
+       'Forms!FÜbernahme!XComm.CommPort = CLng(GetParameter("WAAGEPORT"))
+       'Forms!FÜbernahme!XCommSteuerung.CommPort = CLng(GetParameter("STEUERUNGPORT"))
+    
+       'DoCmd.Save
+       'DoCmd.Close
+         
+       '4. Vollupdate Label entfernen
+       Forms("MHauptmenü").XVersion2.Caption = ""
+       DoCmd.Save
+    
+      End If
+      
+      DoCmd.Close
+    
+    End If
+    
+    DoCmd.Hourglass False
+    DoCmd.OpenForm "MHauptmenü"
+     
+  End If
+
+
+
+End If
+
+End Sub
+
+Function SetReportControlProperty1(reportname As String, ControlName As String, Controltype As Integer, PropertyName As String, PropertyValue As Variant)
+' Sets the given property of the given control in the given form to the given value
+' If Formname="" then all forms
+' If Controlname="" then all controls
+
+Dim sec1 As Section
+Dim ctl1 As Control
+Dim i As Variant
+
+If reportname = "" Or IsNull(reportname) Then
+'All Reports
+ Dim db1 As Database
+ Dim cnt1 As Container
+ Dim doc1 As Document
+
+ Set db1 = CurrentDb
+  For Each cnt1 In db1.Containers
+   If cnt1.Name = "Reports" Then
+    For Each doc1 In cnt1.Documents
+     DoCmd.OpenReport doc1.Name, acViewDesign
+     
+     On Error Resume Next
+     'look into all sections
+     For i = 0 To 8
+      'If Reports(doc1.Name).Section(i).Visible = True Then
+        Reports(doc1.Name).Controls(ControlName).Properties(PropertyName) = PropertyValue
+        'Set sec1 = Reports(doc1.Name).Section(i)
+        'For Each ctl1 In sec1.Controls
+         'If ctl1.Name = ControlName Or ControlName = "" Or IsNull(ControlName) Then
+          'If Controltype = ctl1.Controltype Or Controltype = -1 Then
+           'On Error Resume Next
+           'ctl1.Properties(PropertyName) = PropertyValue
+          'End If
+         'End If
+        'Next ctl1
+      'End If
+     Next i
+     DoCmd.Save
+     DoCmd.Close
+    Next doc1
+   End If
+ Next cnt1
+
+Else
+ DoCmd.OpenReport reportname, acViewDesign
+ For i = 0 To 8
+  Set sec1 = Reports(reportname).Section(i)
+  For Each ctl1 In sec1.Controls
+   If ctl1.Name = ControlName Or ControlName = "" Or IsNull(ControlName) Then
+    On Error Resume Next
+    ctl1.Properties(PropertyName) = PropertyValue
+   End If
+  Next ctl1
+ Next i
+ DoCmd.Save
+ DoCmd.Close
+End If
+
+
+
+
+
+End Function

wgmaster/vba/Form_MMitgliederKonsistenz.frm

@@ -0,0 +1,134 @@
+Dim temptablename1 As String
+
+
+Private Sub Form_Open(Cancel As Integer)
+
+Dim db1 As Database
+
+LMitglieder.RowSource = ""
+LMitglieder.Requery
+
+
+temptablename1 = "xTempMitgliederInkonsistent"
+Set db1 = CurrentDb
+If TableExists(temptablename1) Then
+ db1.Execute ("DROP TABLE " + temptablename1)
+End If
+db1.Execute ("CREATE TABLE " + temptablename1 + " (MGNR LONG, ProblemKurz TEXT, Problem MEMO);")
+
+FlaechenbindungenBerechnen (year(Now))
+
+CheckConsistency
+
+LMitglieder.RowSource = "SELECT TMitglieder.MGNR AS MGNR, TMitglieder.Nachname, TMitglieder.Vorname, TMitglieder.Ort, TMitglieder.Geschäftsanteile1 AS GA1, TMitglieder.Geschäftsanteile2 AS GA2, TMitglieder.Eintrittsdatum AS Eintritt, TMitglieder.Austrittsdatum AS Austritt, TMitglieder.[Aktives Mitglied] AS Aktiv, xTempFlaechenbindungen.Gesamtflaeche AS Flaeche, xTempMitgliederInkonsistent.ProblemKurz AS Problem FROM (TMitglieder INNER JOIN xTempMitgliederInkonsistent ON TMitglieder.MGNR = xTempMitgliederInkonsistent.MGNR) LEFT JOIN xTempFlaechenbindungen ON TMitglieder.MGNR = xTempFlaechenbindungen.MGNR ORDER BY TMitglieder.MGNR"
+LMitglieder.Requery
+
+
+End Sub
+
+
+Function TableExists(table1) As Boolean
+
+Dim db1 As Database
+Set db1 = CurrentDb
+Dim x As TableDef
+
+For Each x In db1.TableDefs
+ If x.Name = table1 Then
+   TableExists = True
+   Exit Function
+ End If
+Next x
+
+TableExists = False
+
+End Function
+
+Sub CheckConsistency()
+
+Dim db1 As Database
+Dim rs1 As Recordset
+Dim rs2 As Recordset
+Dim aktlesejahr As Long
+
+Set db1 = CurrentDb
+Set rs2 = db1.OpenRecordset(temptablename1)
+
+
+Set rs1 = db1.OpenRecordset("SELECT MGNR FROM TMitglieder WHERE Austrittsdatum<>Null and [Aktives Mitglied]=true")
+While Not rs1.EOF
+ rs2.AddNew
+ rs2("MGNR") = rs1("MGNR")
+ rs2("ProblemKurz") = "AUSTRITTSDATUM ABER AKTIV"
+ rs2("Problem") = "Mitglied hat Austrittsdatum eingetragen und ist trotzdem als aktiv eingetragen"
+ rs2.Update
+ rs1.MoveNext
+Wend
+rs1.Close
+
+Set rs1 = db1.OpenRecordset("SELECT TMitglieder.MGNR FROM TMitglieder INNER JOIN xTempFlaechenbindungen ON TMitglieder.MGNR = xTempFlaechenbindungen.MGNR WHERE [Aktives Mitglied]=false and Gesamtflaeche>0")
+While Not rs1.EOF
+ 
+ rs2.AddNew
+ rs2("MGNR") = rs1("MGNR")
+ rs2("ProblemKurz") = "FLÄCHENBINDG TROTZ INAKTIV"
+ rs2("Problem") = "Mitglied ist als nicht aktiv eingetragen, es sind aber noch gültige Flächenbindungen vorhanden"
+ rs2.Update
+ rs1.MoveNext
+Wend
+rs1.Close
+
+Set rs1 = db1.OpenRecordset("SELECT MGNR FROM TMitglieder WHERE (Geschäftsanteile1>0 or Geschäftsanteile2>0) and [Aktives Mitglied]=false")
+While Not rs1.EOF
+ rs2.AddNew
+ rs2("MGNR") = rs1("MGNR")
+ rs2("ProblemKurz") = "GA TROTZ INAKTIV"
+ rs2("Problem") = "Mitglied ist als nicht aktiv eingetragen, hat aber Geschäftsanteile eingetragen"
+ rs2.Update
+ rs1.MoveNext
+Wend
+rs1.Close
+
+If Month(Now) < 11 Then
+ aktlesejahr = year(Now) - 1
+Else
+ aktlesejahr = year(Now)
+End If
+
+Set rs1 = db1.OpenRecordset("SELECT MGNR FROM TMitglieder WHERE [Aktives Mitglied]=True AND MGNR NOT IN (SELECT DISTINCT MGNR FROM TLieferungen WHERE Year([Datum])>=" + Format(aktlesejahr - 2) + ")")
+While Not rs1.EOF
+ rs2.AddNew
+ rs2("MGNR") = rs1("MGNR")
+ rs2("ProblemKurz") = "3 JAHRE KEINE LIEFERUNG"
+ rs2("Problem") = "Mitglied ist als aktiv eingetragen, hat aber bereits 3 Jahre hintereinander nichts geliefert"
+ rs2.Update
+ rs1.MoveNext
+Wend
+rs1.Close
+
+Set rs1 = db1.OpenRecordset("SELECT MGNR FROM TMitglieder WHERE Austrittsdatum=NULL and [Aktives Mitglied]=false")
+While Not rs1.EOF
+ rs2.AddNew
+ rs2("MGNR") = rs1("MGNR")
+ rs2("ProblemKurz") = "KEIN AUSTRITTSDATUM"
+ rs2("Problem") = "Mitglied hat kein Austrittsdatum eingetragen und ist nicht als aktiv eingetragen"
+ rs2.Update
+ rs1.MoveNext
+Wend
+rs1.Close
+
+
+
+rs2.Close
+
+
+End Sub
+
+Private Sub LMitglieder_DblClick(Cancel As Integer)
+
+DoCmd.OpenForm "FMitglieder", , , "MGNR=" + Format(LMitglieder)
+Forms("FMitglieder")!OAlleMitglieder = True
+Forms("FMitglieder").RequeryListe
+Forms("FMitglieder")!LMitglieder = LMitglieder
+
+End Sub

wgmaster/vba/Form_MMitgliederliste.frm

@@ -0,0 +1,113 @@
+
+Private Sub Babbrechen_Click()
+
+DoCmd.Close
+
+End Sub
+
+Private Sub BOk_Click()
+
+
+Dim SEL1 As String
+Dim where1 As String
+Dim order1 As String
+Dim reportname As String
+
+
+FlaechenbindungenBerechnen (TJahr)
+
+If ODetails = True Then
+ reportname = "BMitgliederlisteDetails"
+ SEL1 = "SELECT TZweigstellen.Name, TMitglieder.MGNR, TMitglieder.Nachname, TMitglieder.Vorname, TMitglieder.Betriebsnummer, TMitglieder.Ort, TMitglieder.Geschäftsanteile1, TMitglieder.Geschäftsanteile2, TMitglieder.Eintrittsdatum, TMitglieder.[Aktives Mitglied], TMitglieder.Straße, TMitglieder.PLZ, TMitglieder.BLZ, TMitglieder.KontoNr, TMitglieder.Eintrittsdatum, TMitglieder.Buchführend, TMitglieder.UID, xTempFlaechenbindungen.Gesamtflaeche FROM (TMitglieder LEFT JOIN TZweigstellen ON TMitglieder.ZNR = TZweigstellen.ZNR) LEFT JOIN xTempFlaechenbindungen ON TMitglieder.MGNR = xTempFlaechenbindungen.MGNR"
+ GROUP1 = ""
+ 'CP 2.1.2008: xTempFlaechenbindungen statt Gruppierung mit TFlaechenbindungen
+ 'SEL1 = "SELECT TZweigstellen.Name, TMitglieder.MGNR, TMitglieder.Nachname, TMitglieder.Vorname, TMitglieder.Betriebsnummer, TMitglieder.Ort, TMitglieder.Geschäftsanteile1, TMitglieder.Geschäftsanteile2, TMitglieder.Eintrittsdatum, TMitglieder.[Aktives Mitglied], Sum(TFlaechenbindungen.Flaeche) AS FlSumme, TMitglieder.Straße, TMitglieder.PLZ, TMitglieder.BLZ, TMitglieder.KontoNr, TMitglieder.Eintrittsdatum, TMitglieder.Buchführend, TMitglieder.UID FROM (TMitglieder INNER JOIN TZweigstellen ON TMitglieder.ZNR = TZweigstellen.ZNR) LEFT JOIN TFlaechenbindungen ON TMitglieder.MGNR = TFlaechenbindungen.MGNR"
+ 'GROUP1 = "GROUP BY TZweigstellen.Name, TMitglieder.MGNR, TMitglieder.Nachname, TMitglieder.Vorname, TMitglieder.Betriebsnummer, TMitglieder.Ort, TMitglieder.Geschäftsanteile1, TMitglieder.Geschäftsanteile2, TMitglieder.Eintrittsdatum, TMitglieder.[Aktives Mitglied], TMitglieder.Straße, TMitglieder.PLZ, TMitglieder.BLZ, TMitglieder.KontoNr, TMitglieder.Eintrittsdatum, TMitglieder.Buchführend, TMitglieder.UID"
+Else
+ reportname = "BMitgliederliste"
+ SEL1 = "SELECT TZweigstellen.Name, TMitglieder.MGNR, TMitglieder.Nachname, TMitglieder.Vorname, TMitglieder.Betriebsnummer, TMitglieder.Ort, TMitglieder.Geschäftsanteile1, TMitglieder.Geschäftsanteile2, TMitglieder.Eintrittsdatum, TMitglieder.[Aktives Mitglied], xTempFlaechenbindungen.Gesamtflaeche FROM (TMitglieder LEFT JOIN TZweigstellen ON TMitglieder.ZNR = TZweigstellen.ZNR) LEFT JOIN xTempFlaechenbindungen ON TMitglieder.MGNR = xTempFlaechenbindungen.MGNR"
+ GROUP1 = ""
+ 'CP 2.1.2008: xTempFlaechenbindungen statt Gruppierung mit TFlaechenbindungen
+ 'SEL1 = "SELECT TZweigstellen.Name, TMitglieder.MGNR, TMitglieder.Nachname, TMitglieder.Vorname, TMitglieder.Betriebsnummer, TMitglieder.Ort, TMitglieder.Geschäftsanteile1, TMitglieder.Geschäftsanteile2, TMitglieder.Eintrittsdatum, TMitglieder.[Aktives Mitglied], Sum(TFlaechenbindungen.Flaeche) AS FlSumme FROM (TMitglieder INNER JOIN TZweigstellen ON TMitglieder.ZNR = TZweigstellen.ZNR) LEFT JOIN TFlaechenbindungen ON TMitglieder.MGNR = TFlaechenbindungen.MGNR "
+ 'GROUP1 = " GROUP BY Name, TMitglieder.MGNR, Nachname, Vorname, Betriebsnummer, TMitglieder.Ort, Geschäftsanteile1, Geschäftsanteile2, Eintrittsdatum, [Aktives Mitglied] "
+End If
+
+DoCmd.OpenReport reportname, acDesign
+
+'CP 2.1.2008: xTempFlaechenbindungen statt Gruppierung mit TFlaechenbindungen
+'where1 = " WHERE (((TFlaechenbindungen.Von)<=[Forms]![MMitgliederliste]![TJahr] Or (TFlaechenbindungen.Von) Is Null) AND ((TFlaechenbindungen.Bis)>=[Forms]![MMitgliederliste]![TJahr] Or (TFlaechenbindungen.Bis) Is Null)) "
+where1 = " WHERE TMitglieder.MGNR>0 "
+If ONurAktiveMitglieder Then
+ 'where1 = where1 + " AND [Aktives Mitglied]=True "
+ 'Aktiv und noch nicht ausgetreten
+  where1 = where1 + " AND ([Aktives Mitglied]=True OR TMitglieder.Austrittsdatum>=DateValue('31.12." + Format([Forms]![MMitgliederliste]!TJahr) + " '))"
+ 'Zum Stichjahr bereits eingetreten
+  where1 = where1 + " AND (TMitglieder.Eintrittsdatum is Null or TMitglieder.Eintrittsdatum<=DateValue('31.12." + Format(Forms!MMitgliederliste!TJahr) + "')) "
+End If
+
+If ONurFlaechenbindungen Then
+ 'CP 2.1.2008: xTempFlaechenbindungen statt Gruppierung mit TFlaechenbindungen
+ where1 = where1 + " AND Gesamtflaeche>0"
+ 'where1 = where1 + " AND TMitglieder.MGNR IN (SELECT DISTINCT TFlaechenbindungen.MGNR FROM TFlaechenbindungen WHERE Von<=" + Format(TJahr) + " AND (Bis>=" + Format(TJahr) + " OR Bis=NULL))"
+End If
+
+'MsgBox (SEL1 + WHERE1 + ORDER1)
+Reports(reportname).RecordSource = SEL1 + where1 + GROUP1 '+ ORDER1
+
+
+'MsgBox (SEL1 + where1 + GROUP1)
+
+
+Reports(reportname).GroupLevel(0).ControlSource = "Name"
+
+Select Case OSortierung
+
+Case 1: 'ORDER1 = " ORDER BY TMitglieder.ZNR,Nachname,Vorname"
+
+Reports(reportname).GroupLevel(1).ControlSource = "Nachname"
+Reports(reportname).GroupLevel(2).ControlSource = "Vorname"
+Reports(reportname).Section(8).ForceNewPage = 0
+Reports(reportname)!TOrt.Visible = False
+
+Case 2: 'ORDER1 = " ORDER BY TMitglieder.ZNR,MGNR"
+
+Reports(reportname).GroupLevel(1).ControlSource = "TMitglieder.MGNR"
+Reports(reportname).GroupLevel(2).ControlSource = "TMitglieder.MGNR"
+Reports(reportname).Section(8).ForceNewPage = 0
+Reports(reportname)!TOrt.Visible = False
+
+Case 3: ' Ort
+
+Reports(reportname).GroupLevel(1).ControlSource = "TMitglieder.Ort"
+Reports(reportname).GroupLevel(2).ControlSource = "TMitglieder.Nachname"
+'Forcenewpage=2
+Reports(reportname).Section(8).ForceNewPage = 2
+Reports(reportname)!TOrt.Visible = True
+
+
+End Select
+
+
+DoCmd.Save
+DoCmd.Close
+DoCmd.OpenReport reportname, acPreview
+
+End Sub
+
+
+
+Private Sub Form_Open(Cancel As Integer)
+
+ODetails = False
+ONurAktiveMitglieder = True
+ONurFlaechenbindungen = False
+OSortierung = 1
+
+If Month(Date) < 8 Then
+ TJahr = year(Date) - 1
+Else
+ TJahr = year(Date)
+End If
+
+
+End Sub

wgmaster/vba/Form_MRundschreiben.frm

@@ -0,0 +1,143 @@
+
+Private Sub Babbrechen_Click()
+
+DoCmd.Close
+
+End Sub
+
+Private Sub Befehl54_Click()
+
+
+
+End Sub
+
+Private Sub BExcelExport_Click()
+
+Dim SEL1 As String
+Dim where1 As String
+Dim order1 As String
+Dim query1
+Dim savepath1
+
+SEL1 = "SELECT  TMitglieder.* FROM TMitglieder INNER JOIN TZweigstellen ON TMitglieder.ZNR = TZweigstellen.ZNR"
+
+Select Case OSortierung
+
+Case 1: order1 = " ORDER BY Nachname,Vorname "
+Case 2: order1 = " ORDER BY MGNR "
+Case 3: order1 = " ORDER BY TMitglieder.Ort, TMitglieder.Nachname, TMitglieder.Vorname "
+
+End Select
+
+where1 = " WHERE MGNR > 0 "
+
+If ONurAktiveMitglieder Then
+ where1 = where1 + " AND [Aktives Mitglied]=True "
+End If
+If ONurFlaechenbindungen Then
+ where1 = where1 + " AND TMitglieder.MGNR IN (SELECT DISTINCT TFlaechenbindungen.MGNR FROM TFlaechenbindungen)"
+End If
+If Not IsNull(LZNR) And LZNR <> "" Then
+ where1 = where1 + " AND TMitglieder.ZNR=" + Format(LZNR)
+End If
+
+query1 = SEL1 + where1 + order1
+
+
+savepath1 = InputBox("Excel Datei speichern unter:", "EXCEL DATEI EXPORTIEREN", "C:\Eigene Dateien\mitglieder.xls")
+If IsNull(savepath) Or savepath1 = "" Then
+ Exit Sub
+End If
+
+queryname1 = "AMitgliederExport"
+Dim db1 As Database
+Set db1 = CurrentDb
+
+On Error Resume Next
+DoCmd.DeleteObject acQuery, queryname1
+
+db1.CreateQueryDef queryname1, query1
+db1.Close
+DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel5, queryname1, savepath1, True
+
+End Sub
+
+Function GetWhereClause() As String
+
+Dim where1 As String
+
+where1 = " WHERE MGNR >0 "
+
+If ONurAktiveMitglieder Then
+ where1 = where1 + " AND [Aktives Mitglied]=True "
+End If
+If ONurFlaechenbindungen Then
+ where1 = where1 + " AND TMitglieder.MGNR IN (SELECT DISTINCT TFlaechenbindungen.MGNR FROM TFlaechenbindungen)"
+End If
+If Not IsNull(LZNR) And LZNR <> "" Then
+ where1 = where1 + " AND TMitglieder.ZNR=" + Format(LZNR)
+End If
+
+GetWhereClause = where1
+
+End Function
+
+Private Sub BOk_Click()
+
+
+Dim SEL1 As String
+Dim where1 As String
+Dim order1 As String
+
+SEL1 = "SELECT  TMitglieder.MGNR, Nachname, Vorname, TMitglieder.Ort, TMitglieder.PLZ, TMitglieder.Straße, Geschäftsanteile1, Geschäftsanteile2, Eintrittsdatum, [Aktives Mitglied] FROM TMitglieder INNER JOIN TZweigstellen ON TMitglieder.ZNR = TZweigstellen.ZNR"
+
+
+DoCmd.OpenReport "BRundschreiben", acDesign
+
+Select Case OSortierung
+
+Case 1: 'ORDER1 = " ORDER BY TMitglieder.ZNR,Nachname,Vorname"
+
+Reports!BRundschreiben.GroupLevel(0).ControlSource = "Nachname"
+Reports!BRundschreiben.GroupLevel(1).ControlSource = "Vorname"
+        
+Case 2: 'ORDER1 = " ORDER BY TMitglieder.ZNR,MGNR"
+
+Reports!BRundschreiben.GroupLevel(0).ControlSource = "TMitglieder.MGNR"
+Reports!BRundschreiben.GroupLevel(1).ControlSource = "TMitglieder.MGNR"
+
+Case 3: ' Ort
+
+Reports!BRundschreiben.GroupLevel(0).ControlSource = "TMitglieder.Ort"
+Reports!BRundschreiben.GroupLevel(1).ControlSource = "TMitglieder.Nachname"
+
+End Select
+
+where1 = GetWhereClause()
+
+'MsgBox (SEL1 + WHERE1 + ORDER1)
+Reports!BRundschreiben.RecordSource = SEL1 + where1 '+ ORDER1
+
+DoCmd.Save
+DoCmd.Close
+DoCmd.OpenReport "BRundschreiben", acPreview
+
+End Sub
+
+Private Sub BRundschreibenEMail_Click()
+
+Dim where1 As String
+DoCmd.OpenForm "MRundschreibenEMail"
+where1 = GetWhereClause()
+where1 = where1 + " AND EMail is not null "
+Forms("MRundschreibenEMail").SetWhereClause (where1)
+
+End Sub
+
+Private Sub Form_Open(Cancel As Integer)
+
+ONurAktiveMitglieder = True
+ONurFlaechenbindungen = False
+OSortierung = 1
+
+End Sub

wgmaster/vba/Form_MRundschreibenEMail.frm

@@ -0,0 +1,83 @@
+Dim where1 As String
+
+Private Sub BOk_Click()
+
+Dim adressen As String
+
+adressen = GetEMailadressen()
+subject = TBetreff
+body = TEMailText
+If OVerdeckt Then
+ DoCmd.SendObject acSendReport, "Mitglieder-Information", acFormatPDF, , , adressen, subject, body
+Else
+ DoCmd.SendObject acSendReport, "Mitglieder-Information", acFormatPDF, adressen, , , subject, body
+End If
+End Sub
+
+Function GetEMailadressen() As String
+
+Dim db1 As Database
+Dim rs1 As Recordset
+Dim adressen As String
+Set db1 = CurrentDb
+Set rs1 = db1.OpenRecordset("SELECT * FROM TMitglieder" + where1)
+adressen = ""
+While Not rs1.EOF
+ If Not IsNull(rs1("EMail")) Then
+  adressen = adressen + rs1("EMail") + ";"
+ End If
+ rs1.MoveNext
+Wend
+rs1.Close
+adressen = Left(adressen, Len(adressen) - 1)
+GetEMailadressen = adressen
+
+End Function
+
+Public Sub SetWhereClause(where2 As String)
+
+where1 = where2
+
+LAnzahl.Caption = Format(DCount("MGNR", "TMitglieder", Mid(where1, 8))) + " Mitglieder mit E-Mail Adresse gefunden"
+
+
+End Sub
+
+Private Sub Form_Close()
+
+ SetParameter "RUNDSCHREIBENEMAIL_BETREFF", TBetreff
+ SetParameter "RUNDSCHREIBENEMAIL_EMAILTEXT", TEMailText
+ SetParameter "RUNDSCHREIBENEMAIL_TEXT", TRundschreiben
+
+End Sub
+
+Private Sub Form_Open(Cancel As Integer)
+
+Dim betreff As String
+Dim emailtext As String
+Dim rundschreiben As String
+
+If IsNull(GetParameter("RUNDSCHREIBENEMAIL_BETREFF")) Then
+ betreff = "Rundschreiben"
+ SetParameter "RUNDSCHREIBENEMAIL_BETREFF", betreff
+End If
+betreff = GetParameter("RUNDSCHREIBENEMAIL_BETREFF")
+
+If IsNull(GetParameter("RUNDSCHREIBENEMAIL_EMAILTEXT")) Then
+ emailtext = "Liebe Mitglieder"
+ SetParameter "RUNDSCHREIBENEMAIL_EMAILTEXT", emailtext
+End If
+emailtext = GetParameter("RUNDSCHREIBENEMAIL_EMAILTEXT")
+
+
+If IsNull(GetParameter("RUNDSCHREIBENEMAIL_TEXT")) Then
+ rundschreiben = "Rundschreiben"
+ SetParameter "RUNDSCHREIBENEMAIL_TEXT", rundschreiben
+End If
+rundschreiben = GetParameter("RUNDSCHREIBENEMAIL_TEXT")
+
+TBetreff = betreff
+TEMailText = emailtext
+TRundschreiben = rundschreiben
+
+End Sub

wgmaster/vba/Form_MStammblatt.frm

@@ -0,0 +1,82 @@
+
+Private Sub Babbrechen_Click()
+
+DoCmd.Close
+
+End Sub
+
+Private Sub BOk_Click()
+
+Dim where1 As String
+
+where1 = ""
+If OListe = 1 Then
+    'MGNR
+    If Not IsNull(TVon1) Then
+        where1 = where1 + " AND TMitglieder.MGNR>=" + Format(TVon1)
+    End If
+    If Not IsNull(TBis1) Then
+        where1 = where1 + " AND TMitglieder.MGNR<=" + Format(TBis1)
+    End If
+Else
+    'PLZ
+    If Not IsNull(TVon1) Then
+        where1 = where1 + " AND TMitglieder.PLZ>='" + Format(TVon1) + "'"
+    End If
+    If Not IsNull(TBis1) Then
+        where1 = where1 + " AND TMitglieder.PLZ<='" + Format(TBis1) + "'"
+    End If
+End If
+
+
+Select Case OListe
+
+Case 1:
+ DoCmd.OpenReport "BMitgliedStammblattMGNR", acPreview, , "[Aktives Mitglied]=True AND ZNR=" + Format(Forms!MStammblatt!TZNR) + where1
+Case 2:
+ DoCmd.OpenReport "BMitgliedStammblatt", acPreview, , "[Aktives Mitglied]=True AND ZNR=" + Format(Forms!MStammblatt!TZNR) + where1
+
+End Select
+
+If OLiefermengen Then
+ DoCmd.OpenReport "BLiefermenge", acViewDesign
+ 
+ Select Case OListe
+    Case 1:
+        Reports("BLiefermenge").GroupLevel(0).ControlSource = "MGNR"
+    Case 2:
+        Reports("BLiefermenge").GroupLevel(0).ControlSource = "PLZ"
+ End Select
+
+ DoCmd.Save
+ DoCmd.Close , "BLiefermenge"
+ 
+ DoCmd.OpenReport "BLiefermenge", acPreview, , "[Aktives Mitglied]=True AND ZNR=" + Format(Forms!MStammblatt!TZNR) + where1
+End If
+
+
+
+End Sub
+
+
+
+
+Private Sub Form_Open(Cancel As Integer)
+
+OListe = 1
+OLiefermengen = False
+TZNR = DFirst("ZNR", "TZweigstellen")
+TFusstext = GetParameter("STAMMBLATTTEXT")
+
+End Sub
+
+
+Private Sub TFusstext_Exit(Cancel As Integer)
+
+If IsNull(TFusstext.Value) Then
+ SetParameter "STAMMBLATTTEXT", " "
+Else
+ SetParameter "STAMMBLATTTEXT", TFusstext.Value
+End If
+
+End Sub

wgmaster/vba/Form_MStammdaten.frm

@@ -0,0 +1,89 @@
+Private Sub BBehaelter_Click()
+
+DoCmd.OpenForm "FBehaelter"
+
+End Sub
+
+Private Sub BBehandlungen_Click()
+
+DoCmd.OpenForm "FBehandlungen"
+
+End Sub
+
+Private Sub Befehl17_Click()
+
+DoCmd.OpenForm "FMandant"
+
+End Sub
+
+Private Sub Befehl18_Click()
+
+DoCmd.OpenForm "FBanken"
+
+End Sub
+
+Private Sub Befehl19_Click()
+
+DoCmd.OpenForm "FGebietshierarchie"
+
+End Sub
+
+Private Sub Befehl20_Click()
+
+DoCmd.OpenForm "MStammdaten"
+
+End Sub
+
+Private Sub Befehl22_Click()
+
+DoCmd.OpenForm "FSorten"
+
+End Sub
+
+Private Sub Befehl23_Click()
+
+DoCmd.OpenForm "FQualitaetsstufen"
+
+End Sub
+
+Private Sub Befehl24_Click()
+
+DoCmd.OpenForm "FUmrechnung"
+
+End Sub
+
+Private Sub Befehl25_Click()
+
+DoCmd.OpenForm "FAbschlaege"
+
+End Sub
+
+Private Sub Befehl26_Click()
+
+DoCmd.OpenForm "FAllgemein"
+
+End Sub
+
+Private Sub Befehl27_Click()
+
+DoCmd.OpenForm "FBewirtschaftungsarten"
+
+End Sub
+
+Private Sub Befehl30_Click()
+
+DoCmd.OpenForm "FSortenAttribute"
+
+End Sub
+
+Private Sub BLiefermengen_Click()
+
+DoCmd.OpenForm "FLiefermengen"
+
+End Sub
+
+Private Sub BTextelemente_Click()
+
+DoCmd.OpenForm "FTextelemente"
+
+End Sub

wgmaster/vba/Form_MUnterlieferungen.frm

@@ -0,0 +1,287 @@
+
+Private Sub Babbrechen_Click()
+
+DoCmd.Close
+
+End Sub
+
+Private Sub BOk_Click()
+
+Dim filter1
+
+'filter1 = GetFilter
+filter1 = ""
+
+Select Case OSortierung
+
+Case 1: 'Null-Lieferungen
+
+DoCmd.OpenReport "BNulllieferungen", acViewPreview, , filter1
+        
+Case 2: 'Über/Unterlieferungen
+
+DoCmd.OpenReport "BÜberlieferungen", acViewPreview, , filter1
+
+Case 3: 'Unterlieferungen lt. Flächenbindungen
+
+CreateTempTable
+DoCmd.OpenReport "BUnterlieferungenFlächenbindung", acViewPreview
+
+End Select
+
+
+End Sub
+
+Function GetFilter() As String
+
+Dim filter1 As String
+
+'If IsNull(TZNR) Then
+' filter1 = "TLieferungen.ZNR>=0"
+'Else
+' filter1 = "TLieferungen.ZNR=" + Format(TZNR)
+'End If
+
+If Not IsNull(TLesejahr) Then
+ filter1 = " Year(Datum)=" + Format(TLesejahr)
+End If
+
+GetFilter = filter1
+
+End Function
+
+Private Sub Form_Open(Cancel As Integer)
+
+OSortierung = 1
+TErtragsgrenze = 7500
+TErtragsgrenze.Visible = False
+OAlleAnzeigen.Visible = False
+
+OLiefermengen = False
+
+If Month(Date) < 9 Then
+ TLesejahr = year(Date) - 1
+Else
+ TLesejahr = year(Date)
+End If
+
+End Sub
+
+
+Private Sub OLiefermengen_Click()
+
+If OLiefermengen = True Then
+ TErtragsgrenze.Visible = False
+Else
+ TErtragsgrenze.Visible = True
+End If
+
+End Sub
+
+Private Sub OSortierung_Click()
+
+If OSortierung = 3 Then
+  OLiefermengen.Visible = True
+    If OLiefermengen = True Then
+     TErtragsgrenze.Visible = False
+    Else
+     TErtragsgrenze.Visible = True
+    End If
+ OAlleAnzeigen.Visible = True
+ OAlleAnzeigen = False
+Else
+  OLiefermengen.Visible = False
+ TErtragsgrenze.Visible = False
+ OAlleAnzeigen.Visible = False
+End If
+
+End Sub
+
+Sub CreateTempTable()
+
+
+Dim db1 As Database
+Dim rs1 As Recordset
+Dim rs2 As Recordset
+Dim temptablename As String
+Dim query1 As String
+Dim Lesejahr1
+Dim ERWARTETERERTRAG
+
+Lesejahr1 = Forms!MUnterlieferungen!TLesejahr
+
+temptablename = "xTempFlabiLief"
+Set db1 = CurrentDb
+
+
+'On Error Resume Next
+db1.Execute ("DELETE * FROM " + temptablename)
+'db1.Execute ("CREATE TABLE " + temptablename + "(MGNR LONG,SNR STRING, SANR STRING, SUMMEFLAECHE DOUBLE,SUMMEGEWICHT DOUBLE,ERTRAG DOUBLE,ERWARTETERERTRAG DOUBLE)")
+
+
+Set rs1 = db1.OpenRecordset(temptablename)
+Set rs2 = db1.OpenRecordset("SELECT MGNR,SNR,SANR, Sum(Flaeche) AS SUMFL FROM TFlaechenbindungen WHERE Von<=" + Format(Lesejahr1) + " AND (Bis=Null OR Bis>=" + Format(Lesejahr1) + ") AND NOT ISNULL(SNR) AND NOT ISNULL(MGNR) GROUP BY SNR,SANR, MGNR")
+
+While Not rs2.EOF
+ rs1.AddNew
+ rs1!MGNR = rs2!MGNR
+ rs1!SNR = rs2!SNR
+ If Not IsNull(rs2("SANR")) Then
+  rs1!SANR = rs2!SANR
+ End If
+ rs1!SUMMEFLAECHE = rs2!SUMFL
+ rs1!SummeGewicht = 0
+ rs1!Ertrag = 0
+ rs1.Update
+ 
+ rs2.MoveNext
+Wend
+rs2.Close
+rs1.Close
+
+
+Set db1 = CurrentDb
+'MsgBox (query1)
+
+Set rs1 = db1.OpenRecordset("SELECT * FROM " + temptablename + " ORDER BY MGNR,SNR,SANR")
+
+While Not rs1.EOF
+
+  rs1.Edit
+  If OLiefermengen Then
+   If IsNull(rs1("SANR")) Then
+    ERWARTETERERTRAG = DFirst("ErwarteteLiefermengeProHa", "TLiefermengen", "SNR='" + rs1("SNR") + "' AND SANR IS NULL")
+   Else
+    ERWARTETERERTRAG = DFirst("ErwarteteLiefermengeProHa", "TLiefermengen", "SNR='" + rs1("SNR") + "' AND SANR='" + rs1("SANR") + "'")
+   End If
+  Else
+   ERWARTETERERTRAG = TErtragsgrenze
+  End If
+  If IsNull(ERWARTETERERTRAG) Then
+   ERWARTETERERTRAG = 7500
+  End If
+  rs1!ERWARTETERERTRAG = ERWARTETERERTRAG
+
+ If IsNull(rs1("SANR")) Then
+  query1 = "SELECT Sum(Gewicht) AS SUMKG FROM TLieferungen WHERE Year([Datum]) = " + Format(Lesejahr1) + " And TLieferungen.Storniert <> True AND MGNR=" + Format(rs1("MGNR")) + " AND SNR='" + rs1("SNR") + "' AND SANR IS NULL"
+ Else
+  query1 = "SELECT Sum(Gewicht) AS SUMKG FROM TLieferungen WHERE Year([Datum]) = " + Format(Lesejahr1) + " And TLieferungen.Storniert <> True AND MGNR=" + Format(rs1("MGNR")) + " AND SNR='" + rs1("SNR") + "' AND SANR='" + rs1("SANR") + "'"
+ End If
+ Set rs2 = db1.OpenRecordset(query1)
+ 
+ If rs2.EOF Then
+  'keine Lieferungen gefunden
+  rs1!SummeGewicht = 0
+  rs1!Ertrag = 0
+ Else
+  'lieferung gefunden
+  rs1!SummeGewicht = rs2!SUMKG
+  rs1!Ertrag = rs2!SUMKG * 10000 / rs1!SUMMEFLAECHE
+ End If
+ rs1.Update
+ rs2.Close
+  
+ rs1.MoveNext
+Wend
+rs1.Close
+
+End Sub
+
+Sub CreateTempTable_old()
+
+
+Dim db1 As Database
+Dim rs1 As Recordset
+Dim rs2 As Recordset
+Dim temptablename As String
+Dim query1 As String
+Dim Lesejahr1
+Dim ERWARTETERERTRAG
+
+Lesejahr1 = Forms!MUnterlieferungen!TLesejahr
+
+temptablename = "xTempFlabiLief"
+Set db1 = CurrentDb
+
+
+'On Error Resume Next
+db1.Execute ("DELETE * FROM " + temptablename)
+'db1.Execute ("CREATE TABLE " + temptablename + "(MGNR LONG,SNR STRING, SANR STRING, SUMMEFLAECHE DOUBLE,SUMMEGEWICHT DOUBLE,ERTRAG DOUBLE,ERWARTETERERTRAG DOUBLE)")
+
+
+Set rs1 = db1.OpenRecordset(temptablename)
+Set rs2 = db1.OpenRecordset("SELECT MGNR,SNR,SANR, Sum(Flaeche) AS SUMFL FROM TFlaechenbindungen WHERE Von<=" + Format(Lesejahr1) + " AND (Bis=Null OR Bis>=" + Format(Lesejahr1) + ") AND NOT ISNULL(SNR) AND NOT ISNULL(MGNR) GROUP BY SNR,SANR, MGNR")
+
+While Not rs2.EOF
+ rs1.AddNew
+ rs1!MGNR = rs2!MGNR
+ rs1!SNR = rs2!SNR
+ If Not IsNull(rs2("SANR")) Then
+  rs1!SANR = rs2!SANR
+ End If
+ rs1!SUMMEFLAECHE = rs2!SUMFL
+ rs1!SummeGewicht = 0
+ rs1!Ertrag = 0
+ rs1.Update
+ 
+ rs2.MoveNext
+Wend
+rs2.Close
+rs1.Close
+
+query1 = "SELECT MGNR, UCase(SNR) AS SNR1, SANR, Sum(Gewicht) AS SUMKG FROM TLieferungen WHERE Year([Datum]) = " + Format(Lesejahr1) + " And TLieferungen.Storniert <> True GROUP BY MGNR, SNR,SANR ORDER BY MGNR,SNR, SANR"
+
+Set db1 = CurrentDb
+'MsgBox (query1)
+
+Set rs2 = db1.OpenRecordset(query1)
+Set rs1 = db1.OpenRecordset("SELECT * FROM " + temptablename + " ORDER BY MGNR,SNR,SANR")
+
+While Not rs2.EOF And Not rs1.EOF
+
+  
+ If rs1!MGNR = rs2!MGNR And rs1!SNR = rs2!SNR1 And (IsNull(rs1!SANR) Or rs1!SANR = rs2!SANR) Then
+  rs1.Edit
+  rs1!SummeGewicht = rs2!SUMKG
+  rs1!Ertrag = rs2!SUMKG * 10000 / rs1!SUMMEFLAECHE
+  If OLiefermengen Then
+   If IsNull(rs1("SANR")) Then
+    ERWARTETERERTRAG = DFirst("ErwarteteLiefermengeProHa", "TLiefermengen", "SNR='" + rs1("SNR") + "' AND SANR IS NULL")
+   Else
+    ERWARTETERERTRAG = DFirst("ErwarteteLiefermengeProHa", "TLiefermengen", "SNR='" + rs1("SNR") + "' AND SANR='" + rs1("SANR") + "'")
+   End If
+  Else
+   ERWARTETERERTRAG = TErtragsgrenze
+  End If
+  If IsNull(ERWARTETERERTRAG) Then
+   ERWARTETERERTRAG = 7500
+  End If
+  rs1!ERWARTETERERTRAG = ERWARTETERERTRAG
+  rs1.Update
+  rs1.MoveNext
+ Else
+  ' Step to next equal SNR
+  If rs1!MGNR = rs2!MGNR Then
+  
+   If (rs1!SNR < rs2!SNR1) Then
+     rs1.MoveNext
+   Else
+     rs2.MoveNext
+   End If
+  Else
+  ' Step to next equal MGNR
+   If (rs1!MGNR < rs2!MGNR) Then
+     rs1.MoveNext
+   Else
+     rs2.MoveNext
+   End If
+  End If
+  
+ End If
+ 
+
+ 
+Wend
+
+
+End Sub

wgmaster/vba/MAuszahlung.bas

@@ -0,0 +1,522 @@
+Option Compare Database
+Option Explicit
+
+Sub GebundenBerechnen(Jahr1 As Long, SortenattributeBeiFlächenbindungOptional As Boolean, GebundenBerücksichtigen As Boolean)
+
+ Dim db1 As Database
+ Dim rs1 As Recordset
+ Dim rs2 As Recordset
+ Dim rs3 As Recordset
+
+ Dim actMGNR As Long
+ Dim actSNR As String
+ Dim actSANR As String
+ Dim rsSANR As String
+ Dim actLieferrecht As Double
+ Dim actLieferrecht_Attribute(0 To 255) As Double
+ Dim actLieferungGebunden As Double
+ Dim actBetrag As Double
+ Dim GewichtGebunden As Double
+ Dim GewichtGebundenGrundsorte As Double
+ Dim test1
+ 
+ 
+ Dim ErgebnisGewicht As Double
+ Dim ErgebnisBetrag As Double
+ Dim ErgebnisGebunden As Double
+ Dim ErgebnisDatensaetze As Double
+ Dim ErgebnisAktDatensatz As Double
+ 
+ Dim query1 As String
+ Dim query2 As String
+ Dim zwi
+ Dim maxertrag As Double
+ Dim KgProHa
+ Dim attribute_count As Long
+ Dim i As Long
+ Dim j As Long
+ Dim ImmerUngebunden As Boolean
+ 
+ 
+ 
+DoCmd.Hourglass True
+
+ 
+ 'maxertrag = GetParameter("MAXERTRAG")
+ 
+ Set db1 = CurrentDb
+   
+ query1 = "SELECT * FROM TSorten INNER JOIN (TMitglieder INNER JOIN TLieferungen ON TMitglieder.MGNR = TLieferungen.MGNR) ON TSorten.SNR = TLieferungen.SNR WHERE Oechsle>0 AND TLieferungen.SNR>'' AND Year([Datum]) = " + Format(Jahr1) + " ORDER BY TLieferungen.MGNR, TLieferungen.SNR, TLieferungen.SANR DESC,  TLieferungen.LINR;"
+ 'query1 = "SELECT * FROM (TSorten INNER JOIN (TMitglieder INNER JOIN TLieferungen ON TMitglieder.MGNR = TLieferungen.MGNR) ON TSorten.SNR = TLieferungen.SNR) LEFT JOIN TSortenAttribute ON TLieferungen.SANR = TSortenAttribute.SANR WHERE Oechsle>0 AND TLieferungen.SNR>'' AND Year([Datum]) = " + Format(jahr1) + " ORDER BY TLieferungen.MGNR, TLieferungen.SNR, TLieferungen.SANR DESC,  TLieferungen.LINR;"
+ Set rs1 = db1.OpenRecordset(query1)
+ 
+ actMGNR = -1
+ actSNR = ""
+ actSANR = ""
+ 
+
+ While Not rs1.EOF
+
+  rs1.Edit
+  
+  If actMGNR <> rs1![TLieferungen.MGNR] Then
+  ' Nächstes Mitglied
+   actMGNR = rs1![TLieferungen.MGNR]
+   actSNR = "----"
+   actSANR = "----"
+  End If
+  
+  If Not IsNull(rs1![SANR]) And rs1!SANR <> "" Then
+   rsSANR = UCase(rs1![SANR])
+   ImmerUngebunden = DFirst("ImmerUngebunden", "TSortenAttribute", "SANR='" + rsSANR + "'")
+  Else
+   rsSANR = ""
+   ImmerUngebunden = False
+  End If
+  
+  GewichtGebunden = 0
+  GewichtGebundenGrundsorte = 0
+  
+  If SortenattributeBeiFlächenbindungOptional = True Then
+      
+      'A Sortenattribute in Flaechenbindung optional
+        
+      actSANR = rsSANR
+      
+      'Feststellen der Lieferrechte bei Sortenwechsel
+      If actSNR <> UCase(rs1![TLieferungen.SNR]) Then
+       
+        actSNR = UCase(rs1![TLieferungen.SNR])
+        
+        KgProHa = DFirst("kgproHa", "TSorten", "SNR='" + actSNR + "'")
+        
+        'maxertrag für Grundsorte bestimmen
+        If Not IsNull(KgProHa) And KgProHa > 0 Then
+         maxertrag = KgProHa
+        Else
+         maxertrag = GetParameter("MAXERTRAG")
+        End If
+               
+        'Lieferrecht für Grundsorte errechnen
+        zwi = DSum("Flaeche", "TFlaechenbindungen", "MGNR=" + Format(actMGNR) + " AND SNR='" + Format(actSNR) + "' AND [Von]<=" + Format(Jahr1) + " AND (Bis>=" + Format(Jahr1) + " OR Isnull(Bis))")
+        If IsNull(zwi) Then
+         actLieferrecht = 0
+         zwi = 0
+        Else
+         actLieferrecht = zwi * maxertrag / 10000
+        End If
+        
+        'maxertrag für jedes Attribut bestimmen
+        Set rs3 = db1.OpenRecordset("SELECT * FROM TSortenattribute ORDER BY SANR")
+        i = 0
+        While Not rs3.EOF
+          KgProHa = rs3("kgproha")
+         If Not IsNull(KgProHa) And KgProHa > 0 Then
+          actLieferrecht_Attribute(i) = zwi * KgProHa / 10000
+         Else
+          actLieferrecht_Attribute(i) = zwi * GetParameter("MAXERTRAG") / 10000
+         End If
+         rs3.MoveNext
+         i = i + 1
+        Wend
+        rs3.Close
+        attribute_count = i
+      End If
+      
+      
+      If rs1!QSNR >= 3 And (rs1!gebunden = True Or GebundenBerücksichtigen = False) Then
+       
+       If actSANR = "" Then
+         'Grundsorte
+         
+         If rs1!Gewicht < actLieferrecht Then
+         ' Alles
+           GewichtGebunden = rs1!Gewicht
+           actLieferrecht = actLieferrecht - GewichtGebunden
+           
+           'auch für alle Attribute Lieferrecht reduzieren
+           For i = 0 To attribute_count - 1
+            actLieferrecht_Attribute(i) = actLieferrecht_Attribute(i) - GewichtGebunden
+           Next i
+           
+         Else
+          If actLieferrecht > 0 Then
+           ' Ein Teil
+           GewichtGebunden = actLieferrecht
+           actLieferrecht = 0
+           'auch für alle Attribute Lieferrecht reduzieren
+           For i = 0 To attribute_count - 1
+            actLieferrecht_Attribute(i) = actLieferrecht_Attribute(i) - GewichtGebunden
+           Next i
+          
+          Else
+           ' Kein geb. Lieferrecht mehr übrig
+           GewichtGebunden = 0
+          End If
+         End If
+       Else
+         'Sortenattribut
+         
+         'Nur wenn Attribut nicht ohnehin Ungebunden
+         If ImmerUngebunden = False Then
+         
+          'richtigen Eintrag finden
+          Set rs3 = db1.OpenRecordset("SELECT * FROM TSortenattribute ORDER BY SANR")
+          j = 0
+          While Not rs3.EOF And rs3("SANR") <> actSANR
+           rs3.MoveNext
+           j = j + 1
+          Wend
+          rs3.Close
+          If j > attribute_count Then
+           'error
+           MsgBox ("Fehler bei Attributen!")
+          End If
+          
+          If rs1!Gewicht < actLieferrecht_Attribute(j) Then
+          ' Alles
+            GewichtGebunden = rs1!Gewicht
+            actLieferrecht = actLieferrecht - GewichtGebunden
+            
+            'auch für alle Attribute Lieferrecht reduzieren
+            For i = 0 To attribute_count - 1
+             actLieferrecht_Attribute(i) = actLieferrecht_Attribute(i) - GewichtGebunden
+            Next i
+            
+          Else
+           If actLieferrecht_Attribute(j) > 0 Then
+            ' Ein Teil
+            GewichtGebunden = actLieferrecht_Attribute(j)
+            'Lieferrecht bei Grundsorte reduzieren
+            actLieferrecht = actLieferrecht - GewichtGebunden
+            'auch für alle Attribute Lieferrecht reduzieren
+            For i = 0 To attribute_count - 1
+             actLieferrecht_Attribute(i) = actLieferrecht_Attribute(i) - GewichtGebunden
+            Next i
+            
+           Else
+            ' Kein geb. Lieferrecht mehr übrig
+            GewichtGebunden = 0
+           End If
+          End If
+          
+          'Versuche, Rest auf Grundsorte zu verbuchen
+          If GewichtGebunden < rs1!Gewicht And actLieferrecht > 0 Then
+            
+             If rs1!Gewicht - GewichtGebunden < actLieferrecht Then
+             ' Alles
+               GewichtGebundenGrundsorte = rs1!Gewicht - GewichtGebunden
+               actLieferrecht = actLieferrecht - GewichtGebundenGrundsorte
+               
+               'auch für alle Attribute Lieferrecht reduzieren
+               For i = 0 To attribute_count - 1
+                actLieferrecht_Attribute(i) = actLieferrecht_Attribute(i) - GewichtGebundenGrundsorte
+               Next i
+               
+             Else
+              If actLieferrecht > 0 Then
+               ' Ein Teil
+               GewichtGebundenGrundsorte = actLieferrecht
+               actLieferrecht = 0
+               'auch für alle Attribute Lieferrecht reduzieren
+               For i = 0 To attribute_count - 1
+                actLieferrecht_Attribute(i) = actLieferrecht_Attribute(i) - GewichtGebundenGrundsorte
+               Next i
+              
+              Else
+               ' Kein geb. Lieferrecht mehr übrig
+               GewichtGebundenGrundsorte = 0
+              End If
+             End If
+            
+            
+          End If
+        
+        End If
+        
+       End If
+      
+      Else
+       ' Kein Qualitätswein
+       GewichtGebunden = 0
+      End If
+      
+    
+      'MsgBox (Format(rs1!Gewicht) + " " + Format(rs1!Gebunden) + " " + Format(GewichtGebunden))
+    
+      If IsNull(GewichtGebunden) Then GewichtGebunden = 0
+      If IsNull(GewichtGebundenGrundsorte) Then GewichtGebundenGrundsorte = 0
+      
+      'rounding
+      If CLng(GewichtGebunden) < GewichtGebunden Then
+       GewichtGebunden = CLng(GewichtGebunden) + 1
+      Else
+       GewichtGebunden = CLng(GewichtGebunden)
+      End If
+      GewichtGebundenGrundsorte = Int(GewichtGebundenGrundsorte)
+      
+    
+      rs1!BGewichtGebunden = GewichtGebunden
+      rs1!BGewichtGebundenGrundsorte = GewichtGebundenGrundsorte
+      
+      rs1.Update
+      
+        
+  Else
+      'B Strikt = Sortenattribute in Flaechenbindung NICHT optional
+      
+      'Feststellen der Lieferrechte bei Sorten oder Attributswechsel
+      If actSNR <> UCase(rs1![TLieferungen.SNR]) Or (actSANR <> rsSANR) Then
+      ' Nächste Sorte oder Attribut
+       actSNR = UCase(rs1![TLieferungen.SNR])
+       actSANR = rsSANR
+       
+       'maxertrag setzen
+       If actSANR <> "" Then
+        'from Sortenattribut
+            KgProHa = DFirst("kgproHa", "TSortenattribute", "SANR='" + rsSANR + "'")
+            If Not IsNull(KgProHa) And KgProHa > 0 Then
+             maxertrag = KgProHa
+            Else
+             maxertrag = GetParameter("MAXERTRAG")
+            End If
+         zwi = DSum("Flaeche", "TFlaechenbindungen", "MGNR=" + Format(actMGNR) + " AND SNR='" + Format(actSNR) + "' AND SANR='" + actSANR + "' AND [Von]<=" + Format(Jahr1) + " AND (Bis>=" + Format(Jahr1) + " OR Isnull(Bis))") * maxertrag / 10000
+       Else
+         'from Sorte
+            If Not IsNull(rs1!KgProHa) And rs1!KgProHa > 0 Then
+             maxertrag = rs1!KgProHa
+            Else
+             maxertrag = GetParameter("MAXERTRAG")
+            End If
+          zwi = DSum("Flaeche", "TFlaechenbindungen", "MGNR=" + Format(actMGNR) + " AND SNR='" + Format(actSNR) + "' AND (Isnull(SANR) or SANR='') AND [Von]<=" + Format(Jahr1) + " AND (Bis>=" + Format(Jahr1) + " OR Isnull(Bis))") * maxertrag / 10000
+       End If
+       
+       
+       If IsNull(zwi) Then
+        actLieferrecht = 0
+       Else
+        actLieferrecht = zwi
+       End If
+       actLieferungGebunden = 0
+      End If
+      
+      ' actLieferungGewicht
+      
+      
+      
+      'Wieviel ist gebunden ?
+      
+      
+      If rs1!QSNR >= 3 And (rs1!gebunden = True Or GebundenBerücksichtigen = False) And ImmerUngebunden = False Then
+      
+       If rs1!Gewicht < actLieferrecht - actLieferungGebunden Then
+       ' Alles
+         GewichtGebunden = rs1!Gewicht
+         actLieferungGebunden = actLieferungGebunden + GewichtGebunden
+       Else
+         If actLieferungGebunden < actLieferrecht Then
+          ' Ein Teil
+          GewichtGebunden = actLieferrecht - actLieferungGebunden
+          actLieferungGebunden = actLieferrecht
+         Else
+          ' Kein geb. Lieferrecht mehr übrig
+          GewichtGebunden = 0
+         End If
+       End If
+      Else
+       ' Kein Qualitätswein
+       GewichtGebunden = 0
+      End If
+      
+    
+      'MsgBox (Format(rs1!Gewicht) + " " + Format(rs1!Gebunden) + " " + Format(GewichtGebunden))
+    
+      If IsNull(GewichtGebunden) Then GewichtGebunden = 0
+      
+      'round up
+      If CLng(GewichtGebunden) < GewichtGebunden Then
+       GewichtGebunden = CLng(GewichtGebunden) + 1
+      Else
+       GewichtGebunden = CLng(GewichtGebunden)
+      End If
+    
+      rs1!BGewichtGebunden = GewichtGebunden
+      rs1!BGewichtGebundenGrundsorte = 0
+      rs1.Update
+  
+  End If
+
+  rs1.MoveNext
+
+ Wend
+
+ rs1.Close
+
+
+
+DoCmd.Hourglass False
+
+
+End Sub
+
+
+
+
+Sub Auszahlung2015_MwStUmstellen()
+
+Dim db1 As Database
+Dim rs1 As Recordset
+Dim rs2 As Recordset
+Dim faktor As Double
+Dim Buchführend As Boolean
+Dim summe1 As Double
+Dim summe2 As Double
+
+
+Set db1 = CurrentDb
+
+'1. originaldaten sichern
+db1.Execute ("DROP TABLE xTempLieferungen")
+db1.Execute ("CREATE TABLE xTempLieferungen (LINR Integer, MGNR Integer, BTeilzahlung1 DOUBLE, BBetragGebunden DOUBLE, BBetragUngebunden DOUBLE,BTeilzahlung1_neu DOUBLE, BBetragGebunden_neu DOUBLE, BBetragUngebunden_neu DOUBLE, Korrekturbetrag DOUBLE,GesamtBrutto DOUBLE, GesamtBrutto_neu DOUBLE, GesamtBrutto_neu_korrigiert DOUBLE)")
+db1.Execute ("DELETE * FROM xTempLieferungen")
+Set rs1 = db1.OpenRecordset("SELECT * FROM TLieferungen where datum>Datevalue('01.01.2015') order by LINR")
+Set rs2 = db1.OpenRecordset("xTempLieferungen")
+
+While Not rs1.EOF
+ rs2.AddNew
+ rs2("LINR") = rs1("LINR")
+ rs2("MGNR") = rs1("MGNR")
+ rs2("BTeilzahlung1") = rs1("BTeilzahlung1")
+ rs2("BBetragGebunden") = rs1("BBetragGebunden")
+ rs2("BBetragUngebunden") = rs1("BBetragUngebunden")
+ rs2.Update
+ rs1.MoveNext
+Wend
+rs1.Close
+rs2.Close
+
+'2. nettobeträge korrigieren
+Set rs1 = db1.OpenRecordset("SELECT TLieferungen.* FROM TLieferungen WHERE MGNR>0 AND datum>Datevalue('01.01.2015') order by LINR")
+While Not rs1.EOF
+ Buchführend = DFirst("Buchführend", "TMitglieder", "MGNR=" + Format(rs1("MGNR")))
+ 'If buchführend Then
+ ' faktor = 1
+ 'Else
+  faktor = 1.13 / 1.12
+ 'End If
+ Set rs2 = db1.OpenRecordset("SELECT * FROM xTempLieferungen WHERE LINR=" + Format(rs1("LINR")))
+ rs2.Edit
+ rs2("BTeilzahlung1_neu") = rs1("BTeilzahlung1") * faktor
+ rs2("BBetragGebunden_neu") = rs1("BBetragGebunden") * faktor
+ rs2("BBetragUngebunden_neu") = rs1("BBetragUngebunden") * faktor
+ rs2("Korrekturbetrag") = 0
+ rs2.Update
+ rs1.MoveNext
+Wend
+    rs1.Close
+rs2.Close
+
+'3. runden für gleichen Betrag
+Set rs1 = db1.OpenRecordset("SELECT DISTINCT MGNR FROM TLieferungen WHERE MGNR>0 AND MGNR NOT IN (SELECT MGNR FROM TMitglieder WHERE Buchführend=True) AND datum>Datevalue('01.01.2015') order by MGNR")
+While Not rs1.EOF
+ 
+ summe1 = DSum("BTeilzahlung1", "xTempLieferungen", "MGNR=" + Format(rs1("MGNR")))
+ summe2 = 0
+ If summe1 <> 0 Then
+    Set rs2 = db1.OpenRecordset("SELECT * FROM xTempLieferungen WHERE MGNR=" + Format(rs1("MGNR")))
+ 
+    While Not rs2.EOF
+     
+     rs2.Edit
+     rs2("BTeilzahlung1_neu") = Runden(rs2("BTeilzahlung1_neu"), 2)
+     If Not IsNull(rs2("BBetragGebunden_neu")) Then
+      rs2("BBetragGebunden_neu") = Runden(rs2("BBetragGebunden_neu"), 3)
+     End If
+     If Not IsNull(rs2("BBetragUngebunden_neu")) Then
+      rs2("BBetragUngebunden_neu") = Runden(rs2("BBetragUngebunden_neu"), 3)
+     End If
+     summe2 = summe2 + rs2("BTEilzahlung1_neu")
+     rs2.Update
+     rs2.MoveNext
+    Wend
+    rs2.MovePrevious
+    'letzten Eintrag auf korrekte Summe korrigieren
+    rs2.Edit
+    'rs2("Korrekturbetrag") = (summe2 * 1.12 - summe1 * 1.13) / 1.12
+    rs2("Korrekturbetrag") = Runden((Runden(summe2 * 1.12, 2) - Runden(summe1 * 1.13, 2)) / 1.12, 2)
+    rs2("GesamtBrutto") = Runden(summe1 * 1.13, 2)
+    rs2("GesamtBrutto_neu") = Runden(summe2 * 1.12, 2)
+    rs2("GesamtBrutto_neu_korrigiert") = Runden((summe2 - rs2("Korrekturbetrag")) * 1.12, 2)
+    
+    If rs2("GesamtBrutto_neu_korrigiert") > rs2("GesamtBrutto") Then
+     rs2("Korrekturbetrag") = rs2("Korrekturbetrag") + 0.01
+     rs2("GesamtBrutto_neu_korrigiert") = Runden((summe2 - rs2("Korrekturbetrag")) * 1.12, 2)
+    End If
+    If rs2("GesamtBrutto_neu_korrigiert") < rs2("GesamtBrutto") Then
+     rs2("Korrekturbetrag") = rs2("Korrekturbetrag") - 0.01
+     rs2("GesamtBrutto_neu_korrigiert") = Runden((summe2 - rs2("Korrekturbetrag")) * 1.12, 2)
+    End If
+    rs2.Update
+    
+    rs2.Close
+    
+ End If
+ rs1.MoveNext
+Wend
+rs1.Close
+
+'Exit Sub
+'4. Rückübertragung in TLieferungen
+Set rs1 = db1.OpenRecordset("SELECT * FROM xTempLieferungen WHERE BTeilzahlung1>0 ORDER BY LINR")
+While Not rs1.EOF
+ Set rs2 = db1.OpenRecordset("SELECT * FROM TLieferungen where LINR=" + Format(rs1("LINR")))
+ If Not rs2.EOF Then
+  rs2.Edit
+  rs2("BTeilzahlung1") = Runden(rs1("BTeilzahlung1_neu") - rs1("Korrekturbetrag"), 2)
+  rs2("BBetragGebunden") = rs1("BBetragGebunden_neu")
+  rs2("BBetragUngebunden") = rs1("BBetragUngebunden_neu")
+  rs2.Update
+ End If
+ rs2.Close
+ rs1.MoveNext
+Wend
+rs1.Close
+
+End Sub
+
+
+Sub Auszahlung2015_NettoPreiseProKg_anheben()
+
+Dim db1 As Database
+Dim rs1 As Recordset
+
+Dim faktor As Double
+
+Set db1 = CurrentDb
+faktor = 1.13 / 1.12
+Set rs1 = db1.OpenRecordset("SELECT * FROM TAuszahlungSorten WHERE AZNR=140")
+While Not rs1.EOF
+rs1.Edit
+If Not IsNull(rs1("Betrag")) Then
+ rs1("Betrag") = Runden(faktor * rs1("Betrag"), 3)
+End If
+rs1.Update
+rs1.MoveNext
+Wend
+rs1.Close
+
+Set rs1 = db1.OpenRecordset("SELECT * FROM TAuszahlungSortenQualitätsstufe WHERE AZNR=140")
+While Not rs1.EOF
+rs1.Edit
+If Not IsNull(rs1("Betrag")) Then
+ rs1("Betrag") = Runden(faktor * rs1("Betrag"), 3)
+End If
+rs1.Update
+rs1.MoveNext
+Wend
+rs1.Close
+
+
+
+End Sub
+

wgmaster/vba/MChargen.bas

@@ -0,0 +1,613 @@
+Option Compare Database
+Option Explicit
+
+Function GetActiveCharge(SNR1 As String, QSNR1 As Long, ZNR1 As Long, Optional ByVal SANR1 As Variant) As Long
+
+Dim db1 As Database
+Dim rs1 As Recordset
+
+Set db1 = CurrentDb
+
+'1. Suche nach Charge, die alle Kriterien erfüllt
+If Not IsNull(SANR1) And SANR1 <> "" Then
+ Set rs1 = db1.OpenRecordset("SELECT * FROM TChargen WHERE SNR='" + SNR1 + "' AND SANR='" + SANR1 + "' AND (QSNRVon<=" + Format(QSNR1) + " OR ISNULL(QSNRVon)) AND (QSNRBis>=" + Format(QSNR1) + " OR IsNull(QSNRBis)) AND ZNR=" + Format(ZNR1) + " AND CSNR=2")
+Else
+ Set rs1 = db1.OpenRecordset("SELECT * FROM TChargen WHERE SNR='" + SNR1 + "' AND (QSNRVon<=" + Format(QSNR1) + " OR ISNULL(QSNRVon)) AND (QSNRBis>=" + Format(QSNR1) + " OR IsNull(QSNRBis)) AND ZNR=" + Format(ZNR1) + " AND CSNR=2")
+End If
+If rs1.EOF Then
+ GetActiveCharge = -1
+Else
+ GetActiveCharge = rs1("CNR")
+End If
+rs1.Close
+
+End Function
+
+Public Function ChargeBefuellen(CNR1 As Long, LINR1 As Long) As Boolean
+
+Dim db1 As Database
+Dim rsc As Recordset
+Dim rsl As Recordset
+Dim rsb As Recordset
+Dim verbuchen As Boolean
+
+ChargeBefuellen = False
+Set db1 = CurrentDb
+
+'1. Öffnen der Datensätze
+Set rsc = db1.OpenRecordset("SELECT * FROM TChargen WHERE CNR=" + Format(CNR1))
+If rsc.EOF Then
+ rsc.Close
+ MsgBox ("Charge nicht gefunden!")
+ Exit Function
+End If
+
+Set rsl = db1.OpenRecordset("SELECT * FROM TLieferungen WHERE LINR=" + Format(LINR1))
+If rsl.EOF Then
+ rsl.Close
+ MsgBox ("Lieferung nicht gefunden!")
+ Exit Function
+End If
+
+Set rsb = db1.OpenRecordset("SELECT * FROM TBehaelter WHERE BNR=" + Format(rsc("BNR")))
+If rsb.EOF Then
+ rsb.Close
+ MsgBox ("Behälter nicht gefunden!")
+ Exit Function
+End If
+
+'2. Überprüfen, ob Charge im richtigen Status und Lieferung zugeordnet
+'TODO
+'Charge im Status 2?
+'Lieferung ist diese Charge zugeordnet?
+'Chargentyp=Maische?
+
+
+If rsl("AufChargeVerbucht") = True Then
+ If MsgBox("Diese Lieferung wurde bereits verbucht! Sind Sie sicher, diese Lieferung nochmals zu verbuchen?", vbYesNo) = vbYes Then
+  verbuchen = True
+ Else
+  verbuchen = False
+ End If
+Else
+ verbuchen = True
+End If
+
+
+'3. Aktualisierung Menge und Oechsle unter Berücksichtigung des Reduktionsfaktors
+If verbuchen = True Then
+
+    rsc.Edit
+    If IsNull(rsc("Oechsle")) Or IsNull(rsc("Menge")) Then
+     'erste lieferung
+     rsc("Oechsle") = rsl("Oechsle")
+     rsc("Menge") = rsl("Gewicht")
+    Else
+     rsc("Oechsle") = (rsc("Menge") * rsc("Oechsle") + rsl("Gewicht") * rsl("Oechsle")) / (rsc("Menge") + rsl("Gewicht"))
+     rsc("Menge") = rsc("Menge") + rsl("Gewicht")
+    
+    End If
+    
+    
+    '4. Überprüfung der Charge, ob voll wird
+    'If rsc("Menge") > rsb("MaxMenge") And GetParameter("CHARGENWARNUNG_BEHAELTERVOLL") = "Ja" Then
+    ' If MsgBox("Der Behälter der ausgewählten Charge wird mit dieser Lieferung überfüllt! Wollen Sie die Befüllung trotzdem durchführen?", vbYesNo) = vbYes Then
+    '  rsc.update
+    ' Else
+    ' End If
+    'Else
+    rsc.Update
+    
+    '5. Aktualisieren der Lieferung
+    'rsl.Edit
+    'rsl("AufChargeVerbucht") = True
+    'rsl.Update
+    ChargeBefuellen = True
+End If
+
+
+rsc.Close
+rsb.Close
+rsl.Close
+
+End Function
+
+Public Sub ChargeBefuellungRueckgaengig(CNR1 As Long, LINR1 As Long)
+
+Dim db1 As Database
+Dim rsc As Recordset
+Dim rsl As Recordset
+Dim rsb As Recordset
+Dim verbuchen As Boolean
+
+Set db1 = CurrentDb
+
+'1. Öffnen der Datensätze
+Set rsc = db1.OpenRecordset("SELECT * FROM TChargen WHERE CNR=" + Format(CNR1))
+If rsc.EOF Then
+ rsc.Close
+ MsgBox ("Charge nicht gefunden!")
+ Exit Sub
+End If
+
+Set rsl = db1.OpenRecordset("SELECT * FROM TLieferungen WHERE LINR=" + Format(LINR1))
+If rsl.EOF Then
+ rsl.Close
+ MsgBox ("Lieferung nicht gefunden!")
+ Exit Sub
+End If
+
+If rsl("AufChargeVerbucht") = False Then
+ If MsgBox("Diese Lieferung wurde noch gar nicht verbucht! Sind Sie sicher, die Verbuchung rückgängig zu machen?", vbYesNo) = vbYes Then
+  verbuchen = True
+ Else
+  verbuchen = False
+ End If
+Else
+ verbuchen = True
+End If
+
+If verbuchen = True Then
+'2. Aktualisierung Menge und Oechsle unter Berücksichtigung des Reduktionsfaktors
+rsc.Edit
+If rsc("Oechsle") > 0 And rsc("Menge") > rsl("Gewicht") Then
+ rsc("Oechsle") = (rsc("Oechsle") * rsc("Menge") - rsl("Gewicht") * rsl("Oechsle")) / (rsc("Menge") - rsl("Gewicht"))
+ rsc("Menge") = rsc("Menge") - rsl("Gewicht")
+End If
+rsc.Update
+
+'3. Verbuchung Kennzeichnung aufheben
+rsl.Edit
+rsl("AufChargeVerbucht") = False
+rsl.Update
+End If
+
+
+rsc.Close
+rsl.Close
+
+End Sub
+
+
+
+Function NeueCharge(Optional Lesejahr As Long) As Long
+
+Dim db1 As Database
+Dim rsc As Recordset
+Dim CNR1 As Long
+
+Set db1 = CurrentDb
+
+Set rsc = db1.OpenRecordset("SELECT * FROM TChargen")
+
+'If rsc.recordcount = 0 Then
+' CNR1 = 1
+'Else
+' CNR1 = DMax("CNR", "TChargen") + 1
+'End If
+
+rsc.AddNew
+'rsc("CNR") = CNR1
+NeueCharge = rsc("CNR")
+rsc("Menge") = 0
+rsc("ZNR") = GetParameter("LETZTEZNR")
+If Lesejahr > 0 Then
+ rsc("Jahrgang") = Lesejahr
+End If
+rsc("CSNR") = 1
+rsc("Art") = "Maische"
+rsc.Update
+rsc.Close
+
+End Function
+
+Function ChargeClonen(CNR1 As Long, BNR1 As Long, Optional Menge1 As Long, Optional Oechsle1 As Long) As Long
+Dim db1 As Database
+Dim rsc As Recordset
+Dim rsc2 As Recordset
+Dim i
+Dim Maxcounter1 As Long
+Set db1 = CurrentDb
+Dim CNR2 As Long
+Set rsc = db1.OpenRecordset("SELECT * FROM TChargen where CNR=" + Format(CNR1))
+Set rsc2 = db1.OpenRecordset("SELECT * FROM TChargen")
+
+If Not rsc.EOF Then
+ rsc2.AddNew
+ For i = 0 To rsc2.Fields.Count - 1
+  If rsc2.Fields(i).Name <> "Chargennummer" And rsc2.Fields(i).Name <> "CNR" And rsc2.Fields(i).Name <> "BNR" Then
+   rsc2.Fields(i) = rsc.Fields(i)
+  End If
+ Next i
+ 'CNR2 = DMax("CNR", "TChargen") + 1
+ 'rsc2("CNR") = CNR2
+ ChargeClonen = rsc2("CNR")
+ CNR2 = rsc2("CNR")
+ rsc2("BNR") = BNR1
+ If Not IsNull(Menge1) Then
+  rsc2("Menge") = Menge1
+ End If
+ If Not IsNull(Oechsle1) Then
+  rsc2("Oechsle") = Oechsle1
+ End If
+ rsc2("CSNR") = 2
+ rsc2.Update
+ rsc2.Close
+ Set rsc2 = db1.OpenRecordset("SELECT * FROM TChargen where CNR=" + Format(CNR2))
+ rsc2.Edit
+ rsc2("Chargennummer") = GeneriereChargennummer(rsc2("CNR"), Maxcounter1)
+ rsc2("ChargennummerZaehler") = Maxcounter1
+ rsc2.Update
+End If
+rsc.Close
+rsc2.Close
+
+
+
+End Function
+
+
+Function GeneriereChargennummer(CNR1 As Long, Optional Maxcounter1 As Long) As String
+
+Dim db1 As Database
+Dim rsc As Recordset
+Dim Chargennummer As String
+Dim Maxcounter As Long
+
+Set db1 = CurrentDb
+
+Set rsc = db1.OpenRecordset("SELECT * FROM TChargen WHERE CNR=" + Format(CNR1))
+
+Select Case GetParameter("CHARGENNUMMERTYP")
+
+Case "1": 'BehälterKurzbezeichnung + Zähler (pro Behälter)+ DatumBefüllung
+
+ If rsc("BNR") > 0 And rsc("Jahrgang") > 0 Then
+  If IsNull(DMax("ChargennummerZaehler", "TChargen", "BNR=" + Format(rsc("BNR")) + " AND Jahrgang=" + Format(rsc("Jahrgang")))) Then
+    Maxcounter = 0
+  Else
+   Maxcounter = DMax("ChargennummerZaehler", "TChargen", "BNR=" + Format(rsc("BNR")) + " AND Jahrgang=" + Format(rsc("Jahrgang")))
+  End If
+  Chargennummer = DFirst("Kurzbezeichnung", "TBehaelter", "BNR=" + Format(rsc("BNR"))) + "-" + Format(Maxcounter + 1, "0000") + "-" + Format(year(Date), "0000") + Format(Month(Date), "00") + Format(Day(Date), "00")
+  Maxcounter1 = Maxcounter + 1
+ End If
+ 
+Case "2":
+
+
+Case "3":
+
+
+End Select
+
+rsc.Close
+GeneriereChargennummer = Chargennummer
+
+End Function
+
+
+Sub ChargeBefuellungStarten(CNR1 As Long)
+
+Dim db1 As Database
+Dim rsc As Recordset
+
+Set db1 = CurrentDb
+
+Set rsc = db1.OpenRecordset("SELECT * FROM TChargen WHERE CNR=" + Format(CNR1))
+
+If Not rsc.EOF Then
+
+ 'div. Abfragen
+ If rsc("CSNR") <> 1 Then
+  MsgBox "Die Befüllung kann nur aus dem Zustand 'Erstellt' aus starten!", vbCritical
+  rsc.Close
+  Exit Sub
+ End If
+ 
+ If IsNull(rsc("BNR")) Then
+  MsgBox "Bitte zuerst einen Behälter zuweisen!", vbCritical
+  rsc.Close
+  Exit Sub
+ End If
+ 
+ 
+ rsc.Edit
+ rsc("CSNR") = 2
+ rsc("Befuellungsbeginn") = Date
+ rsc.Update
+
+End If
+rsc.Close
+
+
+
+
+End Sub
+
+Sub ChargeBefuellungBeenden(CNR1 As Long)
+
+Dim db1 As Database
+Dim rsc As Recordset
+
+Set db1 = CurrentDb
+
+Set rsc = db1.OpenRecordset("SELECT * FROM TChargen WHERE CNR=" + Format(CNR1))
+
+If Not rsc.EOF Then
+
+ 'div. Abfragen
+ If rsc("CSNR") <> 2 Then
+  MsgBox "Die Befüllung kann nur aus dem Zustand 'Befüllung' aus beendet werden!", vbCritical
+  rsc.Close
+  Exit Sub
+ End If
+ 
+ rsc.Edit
+ rsc("CSNR") = 3
+ rsc("Befuellungsende") = Date
+ rsc.Update
+
+End If
+rsc.Close
+
+
+End Sub
+
+
+Sub ChargenErstellenAusPlanung(date1 As Date)
+
+Dim db1 As Database
+Dim rsp As Recordset
+Dim rsc As Recordset
+Dim CNR1 As Long
+Dim CSNR1 As Long
+
+Set db1 = CurrentDb
+Set rsp = db1.OpenRecordset("SELECT * FROM TLeseplanung WHERE Datum=DateValue('" + Format(date1) + "') ORDER BY SNR")
+If rsp.EOF Then
+ MsgBox "Keine Planung für diesen Tag gefunden!", vbCritical
+ rsp.Close
+ Exit Sub
+End If
+
+If MsgBox("Wollen Sie die Chargen gleich zur Befüllung freigeben?", vbYesNo) = vbYes Then
+ CSNR1 = 2
+Else
+ CSNR1 = 1
+End If
+
+While Not rsp.EOF
+ 
+ CNR1 = NeueCharge(year(rsp("Datum")))
+ Set rsc = db1.OpenRecordset("SELECT * FROM TChargen WHERE CNR=" + Format(CNR1))
+ rsc.Edit
+ rsc("SNR") = rsp("SNR")
+ If Not IsNull(rsp("SANR")) Then
+  rsc("SANR") = rsp("SANR")
+ End If
+ rsc("Befuellungsbeginn") = rsp("Datum")
+ rsc("Jahrgang") = year(rsp("Datum"))
+ If Not IsNull(rsp("QSNRVon")) Then
+  rsc("QSNRVon") = rsp("QSNRVon")
+ End If
+ If Not IsNull(rsp("QSNRBis")) Then
+  rsc("QSNRBis") = rsp("QSNRBis")
+ End If
+ rsc("CSNR") = CSNR1
+  
+ rsc.Update
+ rsc.Close
+ rsp.MoveNext
+Wend
+rsp.Close
+MsgBox ("Bitte den Chargen noch Behälter zuordnen")
+
+End Sub
+
+
+Sub ChargeUmfuellen(CNRVon As Long, CNRNach As Long, Menge As Double, Optional MengeZuruecksetzen As Boolean, Optional OechsleZuruecksetzen As Boolean, Optional StatusEntleert As Boolean)
+
+Dim db1 As Database
+Dim rsvon As Recordset
+Dim rsnach As Recordset
+Dim rsh As Recordset
+Dim rsb As Recordset
+
+Set db1 = CurrentDb
+Set rsvon = db1.OpenRecordset("SELECT * FROM TChargen WHERE CNR=" + Format(CNRVon))
+Set rsnach = db1.OpenRecordset("SELECT * FROM TChargen WHERE CNR=" + Format(CNRNach))
+Set rsh = db1.OpenRecordset("SELECT * FROM TChargenHierarchie WHERE CNR_Parent=" + Format(CNRVon) + " AND CNR_Child=" + Format(CNRNach))
+Set rsb = db1.OpenRecordset("SELECT * FROM TBehaelter WHERE BNR=" + Format(rsnach("BNR")))
+
+'Anwendung des Reduktionsfaktors
+Menge = Menge * rsb("Reduktionsfaktor")
+
+'Überprüfe Überschreitung des Füllstandes der Zielcharge
+If rsb("MaxMenge") < rsnach("Menge") + Menge Then
+ If MsgBox("Die angegebene Menge würde die maximal mögliche Füllmenge des Behälters überschreiten. Maximal sind " + Format(rsb("MaxMenge") - rsnach("Menge")) + " möglich. Wollen Sie trotzdem die Umfüllung vornehmen?", vbYesNo) = vbNo Then
+  rsvon.Close
+  rsnach.Close
+  rsh.Close
+  rsb.Close
+  Exit Sub
+ End If
+End If
+
+
+'Update Hierarchie
+If rsh.EOF Then
+ rsh.AddNew
+ rsh("CNR_Parent") = CNRVon
+ rsh("CNR_Child") = CNRNach
+Else
+ rsh.Edit
+End If
+
+ If IsNull(rsh("Menge")) Then
+  rsh("Menge") = Menge
+ Else
+  rsh("Menge") = rsh("Menge") + Menge
+ End If
+ rsh.Update
+
+'Update Zielcharge
+rsnach.Edit
+If IsNull(rsnach("Menge")) Then
+ rsnach("Menge") = 0
+End If
+If IsNull(rsnach("Oechsle")) Then
+ rsnach("Oechsle") = 0
+End If
+
+
+
+rsnach("Oechsle") = (rsnach("Menge") * rsnach("Oechsle") + Menge * rsvon("Oechsle") * rsb("Reduktionsfaktor")) / (rsnach("Menge") + Menge * rsb("Reduktionsfaktor"))
+rsnach("Menge") = rsnach("Menge") + Menge * rsb("Reduktionsfaktor")
+rsnach.Update
+
+'Update Ursprungscharge
+rsvon.Edit
+If StatusEntleert And rsvon("Menge") <= 0 Then
+ rsvon("CSNR") = 4
+End If
+If MengeZuruecksetzen Then
+ rsvon("Menge") = rsvon("Menge") - Menge
+End If
+If OechsleZuruecksetzen Then
+ rsvon("Oechsle") = Null
+End If
+rsvon.Update
+
+rsvon.Close
+rsnach.Close
+rsh.Close
+rsb.Close
+
+End Sub
+
+Function ChargeStandNachFuellung(LINR1 As Long) As Double
+
+Dim db1 As Database
+Dim rsc As Recordset
+Dim rsl As Recordset
+Dim rsb As Recordset
+Dim ueberfuellt As Double
+
+Set db1 = CurrentDb
+
+'1. Öffnen der Datensätze
+Set rsl = db1.OpenRecordset("SELECT * FROM TLieferungen WHERE LINR=" + Format(LINR1))
+If rsl.EOF Then
+ rsl.Close
+ 'MsgBox ("Lieferung nicht gefunden!")
+ Exit Function
+End If
+
+Set rsc = db1.OpenRecordset("SELECT * FROM TChargen WHERE CNR=" + Format(rsl("CNR")))
+If rsc.EOF Then
+ rsc.Close
+ 'MsgBox ("Charge nicht gefunden!")
+ Exit Function
+End If
+
+Set rsb = db1.OpenRecordset("SELECT * FROM TBehaelter WHERE BNR=" + Format(rsc("BNR")))
+If rsb.EOF Then
+ rsb.Close
+ 'MsgBox ("Behälter nicht gefunden!")
+ Exit Function
+End If
+
+'2. Überprüfen, ob Charge im richtigen Status und Lieferung zugeordnet
+'TODO
+'Charge im Status 2?
+'Lieferung ist diese Charge zugeordnet?
+'Chargentyp=Maische?
+
+If IsNull(rsc("Menge")) Then
+  ueberfuellt = rsl("Gewicht") - rsb("MaxMenge")
+Else
+  ueberfuellt = rsc("Menge") + rsl("Gewicht") - rsb("MaxMenge")
+End If
+ ChargeStandNachFuellung = ueberfuellt
+
+rsc.Close
+rsb.Close
+rsl.Close
+
+
+End Function
+
+
+Sub ChargenZuLieferungenZuordnen(Lesejahr1 As Long, Optional ZNR1 As Long)
+
+Dim db1 As Database
+Dim rsc As Recordset
+Dim rsl As Recordset
+Dim where1 As String
+
+Set db1 = CurrentDb
+
+If ZNR1 > 0 Then
+ where1 = " WHERE Year(Datum)=" + Format(Lesejahr1) + " AND ZNR=" + Format(ZNR1)
+Else
+ where1 = " WHERE Year(Datum)=" + Format(Lesejahr1)
+End If
+where1 = where1 + " AND NOT SNR=Null and not QSNR=Null and not Datum=Null "
+Set rsl = db1.OpenRecordset("SELECT * FROM TLieferungen " + where1)
+While Not rsl.EOF
+ where1 = " WHERE SNR='" + Format(rsl("SNR")) + "' AND Befuellungsbeginn=DateValue('" + Format(rsl("Datum"), "dd.mm.yyyy") + "') "
+ where1 = where1 + " AND (QSNRVon<=" + Format(rsl("QSNR")) + " OR QSNRVon=Null) AND (QSNRBis>=" + Format(rsl("QSNR")) + " OR QSNRBis=Null)"
+ Set rsc = db1.OpenRecordset("SELECT * FROM TChargen " + where1)
+ If IsNull(rsl("CNR")) Then
+  If Not rsc.EOF Then
+   rsl.Edit
+   rsl("CNR") = rsc("CNR")
+   rsl("AufChargeVerbucht") = True
+   rsl.Update
+  End If
+ End If
+ rsl.MoveNext
+Wend
+
+db1.Close
+
+End Sub
+
+
+Sub ChargenLieferungenZuordnungÄndern(LINR1 As Long, CNRVon As Long, CNRNach As Long)
+
+Dim db1 As Database
+Dim rsc_von As Recordset
+Dim rsl As Recordset
+Dim rsc_nach As Recordset
+
+Set db1 = CurrentDb
+
+'1. Öffnen der Datensätze
+Set rsc_von = db1.OpenRecordset("SELECT * FROM TChargen WHERE CNR=" + Format(CNRVon))
+If rsc_von.EOF Then
+ rsc_von.Close
+ MsgBox ("Charge nicht gefunden!")
+ Exit Sub
+End If
+
+Set rsc_nach = db1.OpenRecordset("SELECT * FROM TChargen WHERE CNR=" + Format(CNRNach))
+If rsc_nach.EOF Then
+ rsc_nach.Close
+ MsgBox ("Charge nicht gefunden!")
+ Exit Sub
+End If
+
+Set rsl = db1.OpenRecordset("SELECT * FROM TLieferungen WHERE LINR=" + Format(LINR1))
+If rsl.EOF Then
+ rsl.Close
+ MsgBox ("Lieferung nicht gefunden!")
+ Exit Sub
+End If
+
+
+ChargeBefuellungRueckgaengig CNRVon, LINR1
+ChargeBefuellen CNRNach, LINR1
+
+
+End Sub

wgmaster/vba/MFlaechenbindungen.bas

@@ -0,0 +1,89 @@
+Option Compare Database
+Option Explicit
+
+
+Sub FlaechenbindungenBerechnen(Jahr1 As Long)
+
+Dim db1 As Database
+Dim rs1 As Recordset
+Dim rs2 As Recordset
+Dim temptablename1 As String
+Dim oldMGNR As Long
+Dim countit As Boolean
+Dim summe As Double
+temptablename1 = "xTempFlaechenbindungen"
+
+Set db1 = CurrentDb
+
+Set db1 = CurrentDb
+If TableExists(temptablename1) Then
+ db1.Execute ("DROP TABLE " + temptablename1)
+End If
+db1.Execute ("CREATE TABLE " + temptablename1 + " (MGNR LONG, Gesamtflaeche DOUBLE);")
+Set rs1 = db1.OpenRecordset("SELECT * FROM TFlaechenbindungen ORDER BY MGNR")
+Set rs2 = db1.OpenRecordset(temptablename1)
+oldMGNR = -1
+While Not rs1.EOF
+ If oldMGNR <> rs1("MGNR") Then
+  If oldMGNR <> -1 Then
+   rs2("MGNR") = oldMGNR
+   rs2("Gesamtflaeche") = summe
+   rs2.Update
+  End If
+  rs2.AddNew
+  summe = 0
+ End If
+ 
+ countit = True
+ If IsNull(rs1("Von")) Then
+ Else
+  If rs1("Von") <= Jahr1 Then
+  Else
+   countit = False
+  End If
+ End If
+  
+ If IsNull(rs1("Bis")) Then
+ Else
+  If rs1("Bis") >= Jahr1 Then
+  Else
+   countit = False
+  End If
+ End If
+ 
+ If IsNull(rs1("Flaeche")) Then
+  countit = False
+ End If
+  
+ If countit Then
+  summe = summe + rs1("Flaeche")
+ End If
+ oldMGNR = rs1("MGNR")
+ rs1.MoveNext
+Wend
+rs2.Update
+rs1.Close
+rs2.Close
+
+End Sub
+
+
+
+Function TableExists(table1) As Boolean
+
+Dim db1 As Database
+Set db1 = CurrentDb
+Dim x As TableDef
+
+For Each x In db1.TableDefs
+ If x.Name = table1 Then
+   TableExists = True
+   Exit Function
+ End If
+Next x
+
+   TableExists = False
+
+End Function
+
+

wgmaster/vba/MMigration.bas

@@ -0,0 +1,45 @@
+Option Compare Database
+
+
+
+Sub bankdaten_migration()
+
+Dim db1 As Database
+Dim rs1 As Recordset
+Dim rs2 As Recordset
+Dim MGNR As Long
+Dim KontoNr As String
+Dim BLZ As String
+Set db1 = CurrentDb
+Set rs1 = db1.OpenRecordset("TMitglieder")
+
+db1.Execute ("UPDATE RTRN6730000000000001 Set Übernommen=False")
+While Not rs1.EOF
+ MGNR = rs1("MGNR")
+ If Not IsNull(rs1("KontoNr")) And Not IsNull(rs1("BLZ")) Then
+    KontoNr = rs1("Kontonr")
+    KontoNr = Replace(KontoNr, ".", "")
+    KontoNr = Replace(KontoNr, "-", "")
+    KontoNr = Replace(KontoNr, " ", "")
+    BLZ = rs1("BLZ")
+    While Left(KontoNr, 1) = "0"
+     KontoNr = Mid(KontoNr, 2)
+    Wend
+    
+    Set rs2 = db1.OpenRecordset("SELECT * FROM RTRN6730000000000001 WHERE BLZ='" + BLZ + "' AND KontoNummer='" + KontoNr + "'")
+    If Not rs2.EOF Then
+     rs1.Edit
+     rs1("IBAN") = rs2("IBAN")
+     rs1("BIC") = rs2("BIC")
+     rs1.Update
+     rs2.Edit
+     rs2("Übernommen") = True
+     rs2.Update
+    End If
+ End If
+ rs1.MoveNext
+Wend
+rs1.Close
+
+
+End Sub

wgmaster/vba/MMisc.bas

@@ -0,0 +1,501 @@
+Option Compare Database
+Option Explicit
+
+
+Sub test()
+
+SwitchToolbars (True)
+
+End Sub
+
+Function SwitchToolbars(onoff As Boolean)
+
+'For Runtime
+Exit Function
+
+If (onoff) Then
+
+DoCmd.ShowToolbar "Menüleiste", acToolbarYes '
+DoCmd.ShowToolbar "Formularansicht", acToolbarYes
+DoCmd.ShowToolbar "Datenbank", acToolbarYes
+DoCmd.SetDisplayedCategories (True)
+'ÄndernEigenschaft "StartupForm", dbText, "MHauptmenü"
+ÄndernEigenschaft "StartupShowDBWindow", dbBoolean, True
+ÄndernEigenschaft "StartupShowStatusBar", dbBoolean, True
+ÄndernEigenschaft "AllowFullMenus", dbBoolean, True
+
+Else
+
+DoCmd.ShowToolbar "Menüleiste", acToolbarNo
+DoCmd.ShowToolbar "Formularansicht", acToolbarNo
+DoCmd.ShowToolbar "Datenbank", acToolbarNo
+DoCmd.SetDisplayedCategories (False)
+'ÄndernEigenschaft "StartupForm", dbText, "MHauptmenü"
+ÄndernEigenschaft "StartupShowDBWindow", dbBoolean, False
+ÄndernEigenschaft "StartupShowStatusBar", dbBoolean, False
+ÄndernEigenschaft "AllowFullMenus", dbBoolean, False
+
+
+End If
+
+
+End Function
+
+
+Function StartupValues()
+
+'ÄndernEigenschaft "StartupShowDBWindow", dbBoolean, False
+'ÄndernEigenschaft "StartupShowStatusBar", dbBoolean, False
+
+End Function
+
+Function ÄndernEigenschaft(strEigenschaftenname As String, varEigenschaftentyp As Variant, varEigenschaftenwert As Variant) As Integer
+    Dim dbs As Database, prp As property
+    Const conPropNotFoundError = 3270
+
+    Set dbs = CurrentDb
+    On Error GoTo Ändern_Fehler
+    dbs.Properties(strEigenschaftenname) = varEigenschaftenwert
+    ÄndernEigenschaft = True
+
+Ändern_Ende:
+    Exit Function
+
+Ändern_Fehler:
+
+If Err = conPropNotFoundError Then  ' Eigenschaft nicht gefunden.
+        Set prp = dbs.CreateProperty(strEigenschaftenname, _
+            varEigenschaftentyp, varEigenschaftenwert)
+        dbs.Properties.Append prp
+        Resume Next
+    Else
+        ' Unbekannter Fehler.
+        ÄndernEigenschaft = False
+        Resume Ändern_Ende
+    End If
+End Function
+
+
+Function GetLocalParameter(Name1 As String) As Variant
+
+GetLocalParameter = DFirst("[Wert]", "lParameter", "[Bezeichnung]='" + UCase(Name1) + "'")
+
+End Function
+
+
+Function GetParameter(Name1 As String) As Variant
+
+GetParameter = DFirst("[Wert]", "TParameter", "[Bezeichnung]='" + UCase(Name1) + "'")
+
+End Function
+
+Sub SetParameter(Name1 As String, value1 As String)
+
+Dim db1 As Database
+Dim rs1 As Recordset
+Dim found As Boolean
+
+Set db1 = CurrentDb
+
+Set rs1 = db1.OpenRecordset("SELECT Bezeichnung,Wert FROM TParameter;")
+
+found = False
+rs1.MoveFirst
+While (Not rs1.EOF)
+ If (UCase(rs1!Bezeichnung) = UCase(Name1)) Then found = True
+ rs1.MoveNext
+Wend
+rs1.Close
+
+Set rs1 = db1.OpenRecordset("SELECT Bezeichnung,Wert FROM TParameter;")
+
+If found = True Then
+ rs1.MoveFirst
+ While (UCase(rs1!Bezeichnung) <> UCase(Name1))
+  rs1.MoveNext
+ Wend
+ rs1.Edit
+ rs1!Wert = value1
+ rs1.Update
+Else:
+ rs1.AddNew
+ rs1!Bezeichnung = Name1
+ rs1!Wert = value1
+ rs1.Update
+End If
+
+rs1.Close
+
+
+End Sub
+
+
+Sub SetLocalParameter(Name1 As String, value1 As String)
+
+Dim db1 As Database
+Dim rs1 As Recordset
+Dim found As Boolean
+
+Set db1 = CurrentDb
+
+Set rs1 = db1.OpenRecordset("SELECT Bezeichnung,Wert FROM lParameter;")
+
+found = False
+rs1.MoveFirst
+While (Not rs1.EOF)
+ If (UCase(rs1!Bezeichnung) = UCase(Name1)) Then found = True
+ rs1.MoveNext
+Wend
+rs1.Close
+
+Set rs1 = db1.OpenRecordset("SELECT Bezeichnung,Wert FROM lParameter;")
+
+If found = True Then
+ rs1.MoveFirst
+ While (UCase(rs1!Bezeichnung) <> UCase(Name1))
+  rs1.MoveNext
+ Wend
+ rs1.Edit
+ rs1!Wert = value1
+ rs1.Update
+Else:
+ rs1.AddNew
+ rs1!Bezeichnung = Name1
+ rs1!Wert = value1
+ rs1.Update
+End If
+
+rs1.Close
+
+
+End Sub
+
+
+
+
+Function Qualitätsstufe(Oechsle) As Variant
+
+If IsNull(Oechsle) Then
+     Qualitätsstufe = Null
+Else
+    
+    Dim db1 As Database
+    Dim rs1 As Recordset
+    
+    Set db1 = CurrentDb
+    
+    Qualitätsstufe = ""
+    Set rs1 = db1.OpenRecordset("SELECT Bezeichnung,Von,Bis FROM TQualitaetsstufen;")
+    
+    rs1.MoveFirst
+     
+     While Not rs1.EOF
+      If Oechsle >= rs1!Von And Oechsle <= rs1!Bis Then
+       Qualitätsstufe = rs1!Bezeichnung
+      End If
+      rs1.MoveNext
+     Wend
+    rs1.Close
+
+End If
+
+End Function
+
+Function QSNR(Oechsle As Long) As Long
+
+If IsNull(Oechsle) Then
+     QSNR = Null
+Else
+        
+    Dim db1 As Database
+    Dim rs1 As Recordset
+    
+    Set db1 = CurrentDb
+    
+    QSNR = Null
+    Set rs1 = db1.OpenRecordset("SELECT QSNR,Von,Bis FROM TQualitaetsstufen;")
+    
+    rs1.MoveFirst
+     
+     While Not rs1.EOF
+      If Oechsle >= rs1!Von And Oechsle <= rs1!Bis Then
+       QSNR = rs1!QSNR
+      End If
+      rs1.MoveNext
+     Wend
+    rs1.Close
+End If
+
+End Function
+
+Function Fileexist(filename As String) As Boolean
+
+On Error GoTo NoFile
+
+If FileSystem.GetAttr(filename) >= 0 Then
+ Fileexist = True
+Else
+ Fileexist = False
+End If
+
+Exit Function
+
+NoFile:
+ Fileexist = False
+ Exit Function
+
+End Function
+
+
+Function GetAppPath() As String
+
+Dim db1 As Database
+Set db1 = CurrentDb
+
+'GetAppPath = Mid(db1.Name, 1, Len(db1.Name) - Len("WGMASTER.ACCDB"))
+GetAppPath = Mid(db1.Name, 1, Len(db1.Name) - Len("WGMASTER2010.ACCDB"))
+
+
+End Function
+
+Function GetDataPath() As String
+
+Dim datapath As String
+datapath = DFirst("Data", "Mandanten", "MANR=" + Format(Forms!MMandantenauswahl!LMandanten))
+GetDataPath = datapath
+
+End Function
+
+Function GetPathWithoutFilename(fullpath As String) As String
+
+Dim str1 As String
+
+str1 = fullpath
+
+While Len(str1) > 0 And Mid(str1, Len(str1), 1) <> "\"
+ str1 = Mid(str1, 1, Len(str1) - 1)
+ If str1 = "" Then
+  GetPathWithoutFilename = ""
+  Exit Function
+ End If
+Wend
+
+GetPathWithoutFilename = str1
+
+
+End Function
+
+Function GetLastMANR() As Long
+
+Dim db1 As Database
+Dim rs1 As Recordset
+Dim found As Boolean
+
+Set db1 = CurrentDb
+
+Set rs1 = db1.OpenRecordset("SELECT * FROM Mandanten;")
+
+GetLastMANR = -1
+While (Not rs1.EOF)
+ If rs1!Last = True Then
+  GetLastMANR = rs1!MANR
+ End If
+ rs1.MoveNext
+Wend
+rs1.Close
+
+End Function
+
+
+Sub SetLastMANR(manr1 As Long)
+
+Dim db1 As Database
+Dim rs1 As Recordset
+Dim found As Boolean
+
+Set db1 = CurrentDb
+
+Set rs1 = db1.OpenRecordset("SELECT * FROM Mandanten;")
+
+found = False
+While (Not rs1.EOF)
+
+ If rs1!Last = True Then
+  rs1.Edit
+  rs1!Last = False
+  rs1.Update
+ End If
+ If rs1!MANR = manr1 Then
+  rs1.Edit
+  rs1!Last = True
+  rs1.Update
+ End If
+ rs1.MoveNext
+Wend
+rs1.Close
+
+End Sub
+
+
+Public Function Runden(value1 As Double, digits As Integer) As Double
+
+Dim temp1 As Double
+
+temp1 = value1 * (10 ^ digits)
+
+If (temp1 * 10) Mod 10 = 5 Then
+ temp1 = temp1 + 1
+ temp1 = Fix(temp1)
+ temp1 = temp1 / (10 ^ digits)
+ Runden = temp1
+Else
+ Runden = CLng(value1 * (10 ^ digits)) / (10 ^ digits)
+End If
+
+End Function
+
+
+
+Public Function GetAbschlägeAsString(LINR1 As Long) As String
+ Const separator = " / "
+ Const separator_length = 3
+ Dim db1 As Database
+ Dim rs1 As Recordset
+ Dim resultString As String
+ Set db1 = CurrentDb
+
+ Set rs1 = db1.OpenRecordset("SELECT TAbschlaege.* FROM (TLieferungAbschlag INNER JOIN TAbschlaege ON TLieferungAbschlag.ASNR = TAbschlaege.ASNR) INNER JOIN TLieferungen ON TLieferungAbschlag.LINR = TLieferungen.LINR WHERE TLieferungen.LINR=" + Format(LINR1))
+ 
+ resultString = ""
+ While Not rs1.EOF
+  resultString = resultString + separator + rs1!Bezeichnung
+  rs1.MoveNext
+ Wend
+ rs1.Close
+ If resultString <> "" Then resultString = Mid(resultString, 1 + separator_length)
+ 
+ GetAbschlägeAsString = resultString
+
+End Function
+
+
+Public Function GetSNRAndSANRFromInput(SNRInput As String, SNR As String, SANR As String) As Boolean
+Dim db1 As Database
+Dim rs1 As Recordset
+
+Set db1 = CurrentDb
+Set rs1 = db1.OpenRecordset("SELECT * FROM TSortenAttributeEingabe WHERE SNREingabe='" + SNRInput + "'")
+If Not rs1.EOF Then
+ SNR = rs1("SNR")
+ SANR = rs1("SANR")
+ GetSNRAndSANRFromInput = True
+Else
+ GetSNRAndSANRFromInput = False
+End If
+rs1.Close
+
+End Function
+
+Public Function GetGebietGLNR(SNR As String, QSNR As Long, GLNR As Long) As Long
+Dim db1 As Database
+Dim rs1 As Recordset
+
+Set db1 = CurrentDb
+Set rs1 = db1.OpenRecordset("SELECT WBGNR FROM TGrosslageGebietSorte WHERE SNR='" + SNR + "' AND MinQSNR<=" + Format(QSNR) + " AND GLNR=" + Format(GLNR))
+If rs1.EOF Then
+ rs1.Close
+ 'Standardgebiet nehmen
+ Set rs1 = db1.OpenRecordset("SELECT WBGNR FROM TGrosslagen WHERE GLNR=" + Format(GLNR))
+End If
+GetGebietGLNR = rs1("WBGNR")
+rs1.Close
+
+End Function
+
+Public Function GetGebiet(SNR As String, QSNR As Long, GLNR As Long) As String
+Dim db1 As Database
+Dim rs1 As Recordset
+
+Set db1 = CurrentDb
+Set rs1 = db1.OpenRecordset("SELECT WBGNR FROM TGrosslageGebietSorte WHERE SNR='" + SNR + "' AND MinQSNR<=" + Format(QSNR) + " AND GLNR=" + Format(GLNR))
+If rs1.EOF Then
+ rs1.Close
+ 'Standardgebiet nehmen
+ Set rs1 = db1.OpenRecordset("SELECT WBGNR FROM TGrosslagen WHERE GLNR=" + Format(GLNR))
+End If
+GetGebiet = DFirst("Bezeichnung", "TGebiete", "WBGNR=" + Format(rs1("WBGNR")))
+rs1.Close
+
+End Function
+
+
+Public Function GetHerkunft(SNR1 As String, QSNR1 As Long, GNR1 As Long) As String
+Dim db1 As Database
+Dim rs1 As Recordset
+Dim WBGNR1 As Long
+Dim RGNR1 As Long
+Dim GLNR1 As Long
+
+GLNR1 = DFirst("GLNR", "TGemeinden", "GNR=" + Format(GNR1))
+Set db1 = CurrentDb
+Set rs1 = db1.OpenRecordset("SELECT WBGNR FROM TGrosslageGebietSorte WHERE SNR='" + SNR1 + "' AND MinQSNR<=" + Format(QSNR1) + " AND GLNR=" + Format(GLNR1))
+If Not rs1.EOF Then
+ 'Spezialeintrag für diese Sorte und Qualität existiert
+ WBGNR1 = rs1("WBGNR")
+Else
+ rs1.Close
+ 'Standardgebiet nehmen
+ Set rs1 = db1.OpenRecordset("SELECT WBGNR FROM TGrosslagen WHERE GLNR=" + Format(GLNR1))
+ WBGNR1 = rs1("WBGNR")
+End If
+rs1.Close
+RGNR1 = DFirst("RGNR", "TGebiete", "WBGNR=" + Format(WBGNR1))
+
+If Not IsNull(DFirst("Herkunftsbezeichnung", "TQualitaetsstufen", "QSNR=" + Format(QSNR1))) Then
+ Select Case DFirst("Herkunftsbezeichnung", "TQualitaetsstufen", "QSNR=" + Format(QSNR1))
+  Case "Land": GetHerkunft = "Österreich"
+  Case "Region":  GetHerkunft = DFirst("Bezeichnung", "TRegionen", "RGNR=" + Format(RGNR1))
+  Case "Gebiet":  GetHerkunft = DFirst("Bezeichnung", "TGebiete", "WBGNR=" + Format(WBGNR1))
+  Case "Grosslage": GetHerkunft = DFirst("Bezeichnung", "TGrosslagen", "GLNR=" + Format(GLNR1))
+  Case "Gemeinde": GetHerkunft = DFirst("Bezeichnung", "TGemeinden", "GNR=" + Format(GNR1))
+ End Select
+Else
+ GetHerkunft = DFirst("Bezeichnung", "TRegionen", "RGNR=" + Format(RGNR1))
+End If
+
+
+End Function
+Public Function GetHerkunftBKI(SNR1 As String, QSNR1 As Long, GNR1 As Long) As String
+Dim db1 As Database
+Dim rs1 As Recordset
+Dim WBGNR1 As Long
+Dim RGNR1 As Long
+Dim GLNR1 As Long
+
+GLNR1 = DFirst("GLNR", "TGemeinden", "GNR=" + Format(GNR1))
+Set db1 = CurrentDb
+Set rs1 = db1.OpenRecordset("SELECT WBGNR FROM TGrosslageGebietSorte WHERE SNR='" + SNR1 + "' AND MinQSNR<=" + Format(QSNR1) + " AND GLNR=" + Format(GLNR1))
+If Not rs1.EOF Then
+ 'Spezialeintrag für diese Sorte und Qualität existiert
+ WBGNR1 = rs1("WBGNR")
+Else
+ rs1.Close
+ 'Standardgebiet nehmen
+ Set rs1 = db1.OpenRecordset("SELECT WBGNR FROM TGrosslagen WHERE GLNR=" + Format(GLNR1))
+ WBGNR1 = rs1("WBGNR")
+End If
+rs1.Close
+RGNR1 = DFirst("RGNR", "TGebiete", "WBGNR=" + Format(WBGNR1))
+
+If QSNR1 < 3 Then
+ GetHerkunftBKI = DFirst("Herkunftsbezeichnung", "TQualitaetsstufen", "QSNR=" + Format(QSNR1))
+Else
+ GetHerkunftBKI = DFirst("BKIKuerzel", "TGebiete", "WBGNR=" + Format(WBGNR1))
+End If
+
+End Function
+
+
+
+
+

wgmaster/vba/MProperties.bas

@@ -0,0 +1,398 @@
+Option Compare Database
+Option Explicit
+
+Function SetDataPath()
+
+'SetLinkTablePath "", GetParameter("DATAPATH") + "WGDATEN.ACCDB"
+'SetLinkTablePath "", "D:\PROJEKT\CHRIS\WGMASTER\WGDATEN.ACCDB"
+
+End Function
+
+
+Function SetFormProperty(FormName As String, PropertyName As String, PropertyValue As Variant)
+'Set Form Property, if Formname="" then set Property of all Forms
+
+If FormName = "" Or IsNull(FormName) Then
+ Dim db1 As Database
+ Dim cnt1 As Container
+ Dim doc1 As Document
+
+ Set db1 = CurrentDb
+  For Each cnt1 In db1.Containers
+   If cnt1.Name = "Forms" Then
+    For Each doc1 In cnt1.Documents
+     DoCmd.OpenForm doc1.Name, acDesign
+     On Error Resume Next
+     Forms(doc1.Name).Properties(PropertyName) = PropertyValue
+     DoCmd.Save
+     DoCmd.Close
+    Next doc1
+   End If
+ Next cnt1
+
+Else
+ DoCmd.OpenForm FormName, acDesign
+ Forms(FormName).Properties(PropertyName) = PropertyValue
+ DoCmd.Save
+ DoCmd.Close
+End If
+
+End Function
+
+Function GetFormProperty(FormName As String, PropertyName As String) As Variant
+'Read Form Property
+
+DoCmd.OpenForm FormName, acDesign
+GetFormProperty = Forms(FormName).Properties(PropertyName)
+DoCmd.Close
+
+End Function
+
+Function SetFormControlProperty(FormName As String, ControlName As String, Controltype As Integer, PropertyName As String, PropertyValue As Variant)
+' Sets the given property of the given control in the given form to the given value
+' If Formname="" then all forms
+' If Controlname="" then all controls
+
+Dim sec1 As Section
+Dim ctl1 As Control
+Dim i As Integer
+
+If FormName = "" Or IsNull(FormName) Then
+
+ Dim db1 As Database
+ Dim cnt1 As Container
+ Dim doc1 As Document
+
+ Set db1 = CurrentDb
+  For Each cnt1 In db1.Containers
+   If cnt1.Name = "Forms" Then
+    For Each doc1 In cnt1.Documents
+     DoCmd.OpenForm doc1.Name, acDesign
+     'Search all Sections for desired Control
+     For i = 0 To 4
+      On Error Resume Next
+      Set sec1 = Forms(doc1.Name).Section(i)
+      For Each ctl1 In sec1.Controls
+       If ctl1.Name = ControlName Or ControlName = "" Or IsNull(ControlName) Then
+        'Has the desired control this property ?
+        If Controltype = ctl1.Controltype Or Controltype = -1 Then
+         On Error Resume Next
+         ctl1.Properties(PropertyName) = PropertyValue
+        End If
+       End If
+      Next ctl1
+     Next i
+     DoCmd.Save
+     DoCmd.Close
+    Next doc1
+   End If
+ Next cnt1
+
+Else
+ DoCmd.OpenForm FormName, acDesign
+ For i = 0 To 4
+  Set sec1 = Forms(FormName).Section(i)
+  For Each ctl1 In sec1.Controls
+   If ctl1.Name = ControlName Or ControlName = "" Or IsNull(ControlName) Then
+    On Error Resume Next
+    ctl1.Properties(PropertyName) = PropertyValue
+   End If
+  Next ctl1
+ Next i
+ DoCmd.Save
+ DoCmd.Close
+End If
+
+End Function
+
+Function SetFormSectionProperty(FormName As String, SectionName As String, PropertyName As String, PropertyValue As Variant)
+' Sets the given property of the given section in the given form to the given value
+' If Formname="" then all forms
+' If Sectionname="" then all sections
+
+Dim sec1 As Section
+Dim ctl1 As Control
+Dim i As Integer
+
+If FormName = "" Or IsNull(FormName) Then
+
+ Dim db1 As Database
+ Dim cnt1 As Container
+ Dim doc1 As Document
+
+ Set db1 = CurrentDb
+  For Each cnt1 In db1.Containers
+   If cnt1.Name = "Forms" Then
+    For Each doc1 In cnt1.Documents
+     DoCmd.OpenForm doc1.Name, acDesign
+     'Search all Sections for desired Control
+     For i = 0 To 4
+      On Error Resume Next
+       Set sec1 = Forms(doc1.Name).Section(i)
+       If SectionName = sec1.Name Or SectionName = "" Or IsNull(SectionName) Then
+        sec1.Properties(PropertyName) = PropertyValue
+       End If
+     Next i
+     DoCmd.Save
+     DoCmd.Close
+    Next doc1
+   End If
+ Next cnt1
+
+Else
+ DoCmd.OpenForm FormName, acDesign
+ For i = 0 To 4
+  Set sec1 = Forms(FormName).Section(i)
+  If SectionName = sec1.Name Or SectionName = "" Or IsNull(SectionName) Then
+   On Error Resume Next
+   sec1.Properties(PropertyName) = PropertyValue
+  End If
+ Next i
+ DoCmd.Save
+ DoCmd.Close
+End If
+
+End Function
+
+Function GetFormControlProperty(FormName As String, ControlName As String, PropertyName As String) As Variant
+
+Dim sec1 As Section
+Dim ctl1 As Control
+Dim i As Integer
+
+'Search all Sections for desired Control
+
+DoCmd.OpenForm FormName, acDesign
+For i = 0 To 4
+ Set sec1 = Forms(FormName).Section(i)
+ For Each ctl1 In sec1.Controls
+  If ctl1.Name = ControlName Then
+   GetFormControlProperty = ctl1.Properties(PropertyName)
+   i = 9
+   Exit For
+  End If
+ Next ctl1
+Next i
+DoCmd.Close
+
+End Function
+
+
+Function SetReportProperty(reportname As String, PropertyName As String, PropertyValue As Variant)
+'Set Report Property, if Report Name="" then all Reports
+
+If reportname = "" Or IsNull(reportname) Then
+ Dim db1 As Database
+ Dim cnt1 As Container
+ Dim doc1 As Document
+
+ Set db1 = CurrentDb
+  For Each cnt1 In db1.Containers
+   If cnt1.Name = "Reports" Then
+    For Each doc1 In cnt1.Documents
+     DoCmd.OpenReport doc1.Name, acDesign
+     On Error Resume Next
+     Reports(doc1.Name).Properties(PropertyName) = PropertyValue
+     DoCmd.Save
+     DoCmd.Close
+    Next doc1
+   End If
+ Next cnt1
+Else
+ DoCmd.OpenReport reportname, acViewDesign
+ Reports(reportname).Properties(PropertyName) = PropertyValue
+ DoCmd.Save
+ DoCmd.Close
+End If
+
+End Function
+
+
+Function GetReportProperty(reportname As String, PropertyName As String) As Variant
+'Read Form Property
+
+DoCmd.OpenReport reportname, acViewDesign
+GetReportProperty = Reports(reportname).Properties(PropertyName)
+DoCmd.Close
+
+End Function
+
+Function SetReportControlProperty(reportname As String, ControlName As String, Controltype As Integer, PropertyName As String, PropertyValue As Variant)
+' Sets the given property of the given control in the given form to the given value
+' If Formname="" then all forms
+' If Controlname="" then all controls
+
+Dim sec1 As Section
+Dim ctl1 As Control
+Dim i As Integer
+
+If reportname = "" Or IsNull(reportname) Then
+'All Reports
+ Dim db1 As Database
+ Dim cnt1 As Container
+ Dim doc1 As Document
+
+ Set db1 = CurrentDb
+  For Each cnt1 In db1.Containers
+   If cnt1.Name = "Reports" Then
+    For Each doc1 In cnt1.Documents
+     DoCmd.OpenReport doc1.Name, acViewDesign
+     'Search all Sections for desired Control
+     For i = 0 To 8
+      Set sec1 = Reports(doc1.Name).Section(i)
+      For Each ctl1 In sec1.Controls
+       If ctl1.Name = ControlName Or ControlName = "" Or IsNull(ControlName) Then
+        If Controltype = ctl1.Controltype Or Controltype = -1 Then
+         On Error Resume Next
+         ctl1.Properties(PropertyName) = PropertyValue
+        End If
+       End If
+      Next ctl1
+     Next i
+     DoCmd.Save
+     DoCmd.Close
+    Next doc1
+   End If
+ Next cnt1
+
+Else
+ DoCmd.OpenReport reportname, acViewDesign
+ For i = 0 To 8
+  Set sec1 = Reports(reportname).Section(i)
+  For Each ctl1 In sec1.Controls
+   If ctl1.Name = ControlName Or ControlName = "" Or IsNull(ControlName) Then
+    On Error Resume Next
+    ctl1.Properties(PropertyName) = PropertyValue
+   End If
+  Next ctl1
+ Next i
+ DoCmd.Save
+ DoCmd.Close
+End If
+
+End Function
+
+Function GetReportControlProperty(reportname As String, ControlName As String, PropertyName As String) As Variant
+
+Dim sec1 As Section
+Dim ctl1 As Control
+Dim i As Integer
+
+'Search all Sections for desired Control
+
+DoCmd.OpenReport reportname, acDesign
+For i = 0 To 4
+ Set sec1 = Reports(reportname).Section(i)
+ For Each ctl1 In sec1.Controls
+  If ctl1.Name = ControlName Then
+   On Error Resume Next
+   GetReportControlProperty = ctl1.Properties(PropertyName)
+   i = 9
+   Exit For
+  End If
+ Next ctl1
+Next i
+DoCmd.Close
+
+End Function
+
+Function SetReportSectionProperty(reportname As String, SectionName As String, PropertyName As String, PropertyValue As Variant)
+' Sets the given property of the given control in the given form to the given value
+' If Formname="" then all forms
+' If Controlname="" then all controls
+
+Dim sec1 As Section
+Dim ctl1 As Control
+Dim i As Integer
+
+If reportname = "" Or IsNull(reportname) Then
+'All Reports
+ Dim db1 As Database
+ Dim cnt1 As Container
+ Dim doc1 As Document
+
+ Set db1 = CurrentDb
+  For Each cnt1 In db1.Containers
+   If cnt1.Name = "Reports" Then
+    For Each doc1 In cnt1.Documents
+     DoCmd.OpenReport doc1.Name, acViewDesign
+     'Search all Sections for desired Control
+     For i = 0 To 8
+      On Error Resume Next
+      Set sec1 = Reports(doc1.Name).Section(i)
+      If SectionName = sec1.Name Or SectionName = "" Or IsNull(SectionName) Then
+       On Error Resume Next
+       sec1.Properties(PropertyName) = PropertyValue
+      End If
+     Next i
+     DoCmd.Save
+     DoCmd.Close
+    Next doc1
+   End If
+ Next cnt1
+
+Else
+ DoCmd.OpenReport reportname, acViewDesign
+ For i = 0 To 8
+  Set sec1 = Reports(reportname).Section(i)
+   If SectionName = sec1.Name Or SectionName = "" Or IsNull(SectionName) Then
+    On Error Resume Next
+    sec1.Properties(PropertyName) = PropertyValue
+   End If
+ Next i
+ DoCmd.Save
+ DoCmd.Close
+End If
+
+End Function
+
+
+Function SetLinkTablePath(TableName As String, path1 As String)
+'Set Table Property, if Tablename="" then set Property of all Tables
+ Dim db1 As Database
+ Dim tdf1 As TableDef
+ Set db1 = CurrentDb
+
+ For Each tdf1 In db1.TableDefs
+  If TableName = tdf1.Name Or TableName = "" Or IsNull(TableName) Then
+    If (Left(tdf1.Name, 1) = "T" And TableName = "") Or TableName <> "" Then
+     tdf1.connect = ";DATABASE=" + path1
+     On Error Resume Next
+     tdf1.RefreshLink
+    End If
+  End If
+ Next tdf1
+
+End Function
+
+
+' Example for easy usage : set form backgroundcolors
+
+Function SetBackGroundColor_AllForms(r As Long, g As Long, b As Long)
+ 
+SetFormSectionProperty "", "", "Backcolor", RGB(r, g, b)
+'SetFormControlProperty "", "", -1, "Backcolor", RGB(r, g, b)
+'SetFormControlProperty "", "", acTextBox, "Backcolor", RGB(255, 255, 255)
+'SetFormControlProperty "", "", acComboBox, "Backcolor", RGB(255, 255, 255)
+'SetFormControlProperty "", "", acListBox, "Backcolor", RGB(255, 255, 255)
+
+End Function
+
+Sub test()
+
+'SetBackGroundColor_AllForms &HEE, &HFF, &HEE
+'SetFormControlProperty "", "", acTextBox, "FontSize", 9
+SetFormControlProperty "", "", acComboBox, "FontSize", 9
+
+End Sub
+
+
+
+Function SetDefaultDataPath()
+
+
+ SetLinkTablePath "", GetAppPath + "WGLEER.ACCDB"
+ SetLinkTablePath "Mandanten", GetAppPath + "WGMANDNT.ACCDB"
+
+End Function
+

wgmaster/vba/MTanksanlegen.bas

@@ -0,0 +1,407 @@
+Option Compare Database
+Option Explicit
+
+Sub TanksRoeschitzAnlegen()
+
+Dim db1 As Database
+Dim rs1 As Recordset
+Dim i As Integer
+
+Set db1 = CurrentDb
+Set rs1 = db1.OpenRecordset("TBehaelter")
+
+For i = 1 To 14
+ rs1.AddNew
+ rs1("Kurzbezeichnung") = "T" + Format(i)
+ rs1("Bezeichnung") = "Tank " + Format(i)
+ rs1("BTNR") = 3
+ rs1("MaxMenge") = 99000
+ If i = 14 Then
+  rs1("MaxMenge") = 72600
+ End If
+ rs1("Reduktionsfaktor") = 1
+ 'rs1("BevorzugterSortenTyp") = ""
+ rs1("Pos_X") = 100
+ rs1("Pos_Y") = 4100
+ rs1("MengenEinheit") = "l"
+ rs1("BSNR") = 3
+ rs1.Update
+Next i
+
+For i = 15 To 16
+ rs1.AddNew
+ rs1("Kurzbezeichnung") = "T" + Format(i)
+ rs1("Bezeichnung") = "Tank " + Format(i)
+ rs1("BTNR") = 3
+ rs1("MaxMenge") = 600000
+ rs1("Reduktionsfaktor") = 1
+ 'rs1("BevorzugterSortenTyp") = ""
+ rs1("Pos_X") = 100
+ rs1("Pos_Y") = 4100
+ rs1("MengenEinheit") = "l"
+ rs1("BSNR") = 2
+ rs1.Update
+Next i
+
+
+For i = 17 To 22
+ rs1.AddNew
+ rs1("Kurzbezeichnung") = "T" + Format(i)
+ rs1("Bezeichnung") = "Tank " + Format(i)
+ rs1("BTNR") = 3
+ rs1("MaxMenge") = 15000
+ rs1("Reduktionsfaktor") = 1
+ 'rs1("BevorzugterSortenTyp") = ""
+ rs1("Pos_X") = 100
+ rs1("Pos_Y") = 4100
+ rs1("MengenEinheit") = "l"
+ rs1("BSNR") = 6
+ rs1.Update
+Next i
+
+For i = 23 To 38
+ rs1.AddNew
+ rs1("Kurzbezeichnung") = "T" + Format(i)
+ rs1("Bezeichnung") = "Tank " + Format(i)
+ rs1("BTNR") = 3
+ rs1("MaxMenge") = 30000
+ rs1("Reduktionsfaktor") = 1
+ 'rs1("BevorzugterSortenTyp") = ""
+ rs1("Pos_X") = 100
+ rs1("Pos_Y") = 4100
+ rs1("MengenEinheit") = "l"
+ rs1("BSNR") = 6
+ If i = 35 Then
+ rs1("BSNR") = 2
+ End If
+ rs1.Update
+Next i
+
+
+For i = 39 To 39
+ rs1.AddNew
+ rs1("Kurzbezeichnung") = "T" + Format(i)
+ rs1("Bezeichnung") = "Tank " + Format(i)
+ rs1("BTNR") = 3
+ rs1("MaxMenge") = 5000
+ rs1("Reduktionsfaktor") = 1
+ 'rs1("BevorzugterSortenTyp") = ""
+ rs1("Pos_X") = 100
+ rs1("Pos_Y") = 4100
+ rs1("MengenEinheit") = "l"
+ rs1("BSNR") = 6
+ rs1.Update
+Next i
+
+For i = 40 To 42
+ rs1.AddNew
+ rs1("Kurzbezeichnung") = "T" + Format(i)
+ rs1("Bezeichnung") = "Tank " + Format(i)
+ rs1("BTNR") = 3
+ rs1("MaxMenge") = 7000
+ rs1("Reduktionsfaktor") = 1
+ 'rs1("BevorzugterSortenTyp") = ""
+ rs1("Pos_X") = 100
+ rs1("Pos_Y") = 4100
+ rs1("MengenEinheit") = "l"
+ rs1("BSNR") = 6
+ rs1.Update
+Next i
+
+For i = 43 To 50
+ rs1.AddNew
+ rs1("Kurzbezeichnung") = "T" + Format(i)
+ rs1("Bezeichnung") = "Tank " + Format(i)
+ rs1("BTNR") = 3
+ rs1("MaxMenge") = 3000
+ rs1("Reduktionsfaktor") = 1
+ 'rs1("BevorzugterSortenTyp") = ""
+ rs1("Pos_X") = 100
+ rs1("Pos_Y") = 4100
+ rs1("MengenEinheit") = "l"
+ rs1("BSNR") = 6
+ rs1.Update
+Next i
+
+For i = 51 To 53
+ rs1.AddNew
+ rs1("Kurzbezeichnung") = "T" + Format(i)
+ rs1("Bezeichnung") = "Tank " + Format(i)
+ rs1("BTNR") = 3
+ rs1("MaxMenge") = 1500
+ rs1("Reduktionsfaktor") = 1
+ 'rs1("BevorzugterSortenTyp") = ""
+ rs1("Pos_X") = 100
+ rs1("Pos_Y") = 4100
+ rs1("MengenEinheit") = "l"
+ rs1("BSNR") = 6
+ rs1.Update
+Next i
+
+For i = 9 To 23
+ rs1.AddNew
+ rs1("Kurzbezeichnung") = "Z" + Format(i)
+ rs1("Bezeichnung") = "Zisterne " + Format(i)
+ rs1("BTNR") = 3
+ rs1("MaxMenge") = 25000
+ rs1("Reduktionsfaktor") = 1
+ rs1("BevorzugterSortenTyp") = "Rot"
+ rs1("Pos_X") = 100
+ rs1("Pos_Y") = 4100
+ rs1("MengenEinheit") = "l"
+ rs1("BSNR") = 4
+ rs1.Update
+Next i
+
+For i = 1 To 3
+ rs1.AddNew
+ rs1("Kurzbezeichnung") = "F" + Format(i)
+ rs1("Bezeichnung") = "Fass " + Format(i)
+ rs1("BTNR") = 3
+ rs1("MaxMenge") = 9000
+ rs1("Reduktionsfaktor") = 1
+ rs1("BevorzugterSortenTyp") = "Rot"
+ rs1("Pos_X") = 100
+ rs1("Pos_Y") = 4100
+ rs1("MengenEinheit") = "l"
+ rs1("BSNR") = 5
+ rs1.Update
+Next i
+
+
+
+
+rs1.Close
+
+
+End Sub
+
+Sub PositionenTanksRoeschitz()
+
+Dim db1 As Database
+Dim rs1 As Recordset
+Dim i As Integer
+
+Dim offset_x As Long
+Dim offset_y As Long
+Dim raster_x As Long
+Dim raster_y As Long
+Dim max_x As Long
+Dim current_x As Long
+Dim current_y As Long
+
+offset_x = 100
+offset_y = 550
+raster_x = 2000
+raster_y = 2000
+max_x = 14000
+Set db1 = CurrentDb
+For i = 1 To 7
+Set rs1 = db1.OpenRecordset("SELECT * FROM TBehaelter WHERE BSNR=" + Format(i) + " order by BNR")
+current_x = offset_x
+current_y = offset_y
+While Not rs1.EOF
+ rs1.Edit
+ rs1("Pos_X") = current_x
+ rs1("Pos_Y") = current_y
+ rs1.Update
+ current_x = current_x + raster_x
+ If current_x > max_x Then
+   current_x = offset_x
+   current_y = current_y + raster_x
+ End If
+ rs1.MoveNext
+Wend
+rs1.Close
+Next i
+
+
+
+
+End Sub
+
+
+Sub TanksWinzerkellerAnlegen()
+
+Dim db1 As Database
+Dim rs1 As Recordset
+Dim i As Integer
+
+Set db1 = CurrentDb
+Set rs1 = db1.OpenRecordset("TBehaelter")
+
+For i = 1 To 12
+ rs1.AddNew
+ rs1("Kurzbezeichnung") = "MB" + Format(i)
+ rs1("Bezeichnung") = "Weißwein Maischebehälter " + Format(i)
+ rs1("BTNR") = 2
+ rs1("MaxMenge") = 12000
+ rs1("Reduktionsfaktor") = 1
+ rs1("BevorzugterSortenTyp") = "Weiß"
+ rs1("Pos_X") = 100
+ rs1("Pos_Y") = 4100
+ rs1("MengenEinheit") = "kg"
+ rs1("BSNR") = 1
+ rs1.Update
+Next i
+
+For i = 1 To 5
+ rs1.AddNew
+ rs1("Kurzbezeichnung") = "RT" + Format(i)
+ rs1("Bezeichnung") = "Rührtanks Rotwein " + Format(i)
+ rs1("BTNR") = 3
+ rs1("MaxMenge") = 18000
+ If i > 2 Then
+  rs1("MaxMenge") = 30000
+ End If
+ rs1("Reduktionsfaktor") = 1
+ rs1("BevorzugterSortenTyp") = "Rot"
+ rs1("Pos_X") = 100
+ rs1("Pos_Y") = 4100
+ rs1("MengenEinheit") = "kg"
+ rs1("BSNR") = 1
+ rs1.Update
+Next i
+
+For i = 1 To 4
+ rs1.AddNew
+ rs1("Kurzbezeichnung") = "P" + Format(i)
+ rs1("Bezeichnung") = "Presse " + Format(i)
+ rs1("BTNR") = 1
+ rs1("MaxMenge") = 30000
+ rs1("Reduktionsfaktor") = 0.8
+ 'rs1("BevorzugterSortenTyp") = ""
+ rs1("Pos_X") = 100
+ rs1("Pos_Y") = 4100
+ rs1("MengenEinheit") = "kg"
+ rs1("BSNR") = 1
+ rs1.Update
+Next i
+
+For i = 1 To 5
+ rs1.AddNew
+ rs1("Kurzbezeichnung") = "W" + Format(i)
+ rs1("Bezeichnung") = "Weißwein-Mosttank " + Format(i)
+ rs1("BTNR") = 4
+ rs1("MaxMenge") = 32000
+ If i = 1 Or i = 4 Then rs1("MaxMenge") = 50000
+ rs1("BevorzugterSortenTyp") = "Weiß"
+ rs1("Reduktionsfaktor") = 1
+ rs1("Pos_X") = 100
+ rs1("Pos_Y") = 4100
+ rs1("MengenEinheit") = "l"
+ rs1("BSNR") = 2
+ rs1.Update
+Next i
+
+For i = 6 To 9
+ rs1.AddNew
+ rs1("Kurzbezeichnung") = "R" + Format(i)
+ rs1("Bezeichnung") = "Rotwein-Mosttank " + Format(i)
+ rs1("BTNR") = 4
+ rs1("MaxMenge") = 26000
+ If i = 9 Then rs1("MaxMenge") = 50000
+ rs1("BevorzugterSortenTyp") = "Weiß"
+ rs1("Reduktionsfaktor") = 1
+ rs1("Pos_X") = 100
+ rs1("Pos_Y") = 4100
+ rs1("MengenEinheit") = "l"
+ rs1("BSNR") = 2
+ rs1.Update
+Next i
+
+
+For i = 1 To 3
+ rs1.AddNew
+ rs1("Kurzbezeichnung") = "V" + Format(i)
+ rs1("Bezeichnung") = "Rotwein-Mosttank " + Format(i)
+ rs1("BTNR") = 6
+ rs1("MaxMenge") = 12000
+ rs1("BevorzugterSortenTyp") = "Rot"
+ rs1("Reduktionsfaktor") = 1
+ rs1("Pos_X") = 100
+ rs1("Pos_Y") = 4100
+ rs1("MengenEinheit") = "kg"
+ rs1("BSNR") = 1
+ rs1.Update
+Next i
+
+'Scheitermost
+ rs1.AddNew
+ rs1("Kurzbezeichnung") = "ST" + Format(10)
+ rs1("Bezeichnung") = "Scheitermosttank " + Format(10)
+ rs1("BTNR") = 4
+ rs1("MaxMenge") = 32000
+ rs1("BevorzugterSortenTyp") = "Weiß"
+ rs1("Reduktionsfaktor") = 1
+ rs1("Pos_X") = 100
+ rs1("Pos_Y") = 4100
+ rs1("MengenEinheit") = "kg"
+ rs1("BSNR") = 1
+ rs1.Update
+
+
+
+rs1.Close
+
+
+End Sub
+
+
+
+Sub PositionenTanksWinzerkeller()
+
+Dim db1 As Database
+Dim rs1 As Recordset
+Dim i As Integer
+
+Dim offset_x As Long
+Dim offset_y As Long
+Dim raster_x As Long
+Dim raster_y As Long
+Dim max_x As Long
+Dim current_x As Long
+Dim current_y As Long
+Dim x As String
+
+offset_x = 100
+offset_y = 550
+raster_x = 1700
+raster_y = 1900
+max_x = 14000
+Set db1 = CurrentDb
+For i = 1 To 2
+Set rs1 = db1.OpenRecordset("SELECT * FROM TBehaelter WHERE BSNR=" + Format(i) + " order by BNR")
+current_x = offset_x
+current_y = offset_y
+While Not rs1.EOF
+ rs1.Edit
+ rs1("Pos_X") = current_x
+ rs1("Pos_Y") = current_y
+ rs1.Update
+ current_x = current_x + raster_x
+ 'If MsgBox("Momentaner Behälter=" + Format(rs1("Kurzbezeichnung")) + ". Zeilenumbruch?", vbYesNo) = vbYes Then
+ '  current_x = offset_x
+ '  current_y = current_y + raster_x
+ 'End If
+ x = rs1("Kurzbezeichnung")
+ 
+ If x = "MB6" Or x = "MB12" Or x = "RT5" Or x = "P4" Then
+   current_x = offset_x
+   current_y = current_y + raster_x
+ End If
+ 
+ 
+ If current_x > max_x Then
+   current_x = offset_x
+   current_y = current_y + raster_x
+ End If
+ rs1.MoveNext
+Wend
+rs1.Close
+Next i
+
+
+
+
+End Sub

wgmaster/vba/MTcpSocket.bas

@@ -0,0 +1,215 @@
+Option Compare Database
+
+' Fügen sie diesen Code in ein öffentliches Modul ein
+Private Declare Function gethostbyname Lib "wsock32.dll" ( _
+  ByVal Name As String) As Long
+Private Declare Function socket Lib "wsock32.dll" ( _
+  ByVal af As Long, _
+  ByVal prototype As Long, _
+  ByVal protocol As Long) As Long
+Private Declare Function closesocket Lib "wsock32.dll" (ByVal s As Long) As Long
+Private Declare Function connect Lib "wsock32.dll" ( _
+  ByVal s As Long, _
+  Name As SOCKADDR, _
+  ByVal namelen As Long) As Long
+Private Declare Function send Lib "wsock32.dll" ( _
+  ByVal s As Long, _
+  buf As Any, _
+  ByVal length As Long, _
+  ByVal flags As Long) As Long
+Private Declare Function recv Lib "wsock32.dll" ( _
+  ByVal s As Long, _
+  buf As Any, _
+  ByVal length As Long, _
+  ByVal flags As Long) As Long
+Private Declare Function ioctlsocket Lib "wsock32.dll" ( _
+  ByVal s As Long, _
+   ByVal cmd As Long, _
+  argp As Long) As Long
+Private Declare Function inet_addr Lib "wsock32.dll" ( _
+  ByVal cp As String) As Long
+Private Declare Function htons Lib "wsock32.dll" ( _
+  ByVal hostshort As Integer) As Integer
+Private Declare Function WSAGetLastError Lib "wsock32.dll" () As Long
+Private Declare Sub MoveMemory Lib "kernel32" _
+  Alias "RtlMoveMemory" ( _
+  Destination As Any, _
+  Source As Any, _
+  ByVal length As Long)
+ 
+Private Declare Function WSAStartup Lib "wsock32.dll" ( _
+  ByVal wVersionRequested As Integer, _
+  lpWSAData As WSAData) As Long
+Private Declare Function WSACleanup Lib "wsock32.dll" () As Long
+ 
+Private Type HOSTENT
+  hname As Long
+  haliases As Long
+  haddrtype As Integer
+  hlength As Integer
+  haddrlist As Long
+End Type
+ 
+Private Type SOCKADDR
+  sin_family As Integer
+  sin_port As Integer
+  sin_addr As Long
+  sin_zero As String * 8
+End Type
+
+Private Type WSAData
+  wVersion As Integer
+  wHighVersion As Integer
+  szDescription As String * 257
+  szSystemStatus As String * 129
+  iMaxSockets As Long
+  iMaxUdpDg As Long
+  lpVendorInfo As Long
+End Type
+ 
+
+
+' eine der HOSTENT-haddrtype-Konstanten
+Private Const AF_INET = 2 ' Internet Protokoll (UDP/IP oder TCP/IP).
+ 
+' socket prototype-Konstanten
+Private Const SOCK_STREAM = 1 ' 2-wege Stream. Bei AF_INET ist es das
+' TCP/IP Protokoll
+Private Const SOCK_DGRAM = 2 ' Datagramm Basierende verbindung. Bei AF_INET
+' ist es das UDP Protokoll
+ 
+' recv flags-Konstanten
+Private Const MSG_PEEK = &H2 ' Daten aus dem Puffer lesen, aber nicht aus
+' dem Puffer entfernen
+ 
+' ioctlsocket cmd-Konstanten
+Private Const FIONBIO = &H8004667E ' Setzen ob die Funktion bei der nächsten
+' Datenanfrage zurückkehren soll
+
+Dim hSock As Long
+
+
+' IP-Adresse einer Internetadresse ermitteln
+Public Function GetIP(ByVal HostName As String) As String
+  Dim pHost As Long, HostInfo As HOSTENT
+  Dim pIP As Long, IPArray(3) As Byte
+ 
+  ' Informationen des Host ermitteln
+  pHost = gethostbyname(HostName)
+  If pHost = 0 Then Exit Function
+ 
+  ' HOSTENT-Struktur kopieren
+  MoveMemory HostInfo, ByVal pHost, Len(HostInfo)
+ 
+  ' Pointer der 1ten Ip-Adresse ermitteln
+  ReDim IpAddress(HostInfo.hlength - 1)
+  MoveMemory pIP, ByVal HostInfo.haddrlist, 4
+  MoveMemory IPArray(0), ByVal pIP, 4
+ 
+  GetIP = IPArray(0) & "." & IPArray(1) & "." & IPArray(2) & "." & IPArray(3)
+End Function
+
+' Mit einem Server verbinden
+Public Function ConnectToServer(ByVal ServerIP As String, ByVal ServerPort _
+As Long) As Long
+  Dim Retval As Long, ServerAddr As SOCKADDR
+ 
+  ' Socket erstellen
+  hSock = socket(AF_INET, SOCK_STREAM, 0&)
+  If hSock = -1 Then
+    ConnectToServer = -1
+    Exit Function
+  End If
+ 
+  ' mit dem Server verbinden
+  With ServerAddr
+    .sin_addr = inet_addr(ServerIP)
+    .sin_port = htons(ServerPort)
+    .sin_family = AF_INET
+  End With
+  Retval = connect(hSock, ServerAddr, Len(ServerAddr))
+  If Retval < 0 Then
+    MsgBox ("Connection Error:" + Retval)
+    Call closesocket(hSock)
+    ConnectToServer = -1
+    Exit Function
+  End If
+ 
+  ' Rückkehren der Funktion nach dem Abfragen von ankommenden Daten erzwingen
+  Retval = ioctlsocket(hSock, FIONBIO, 1&)
+ 
+  ' Socket-ID zurückgeben
+  ConnectToServer = hSock
+End Function
+
+' Sock/Verbindung schließen
+Public Function Disconnect(ByRef Sock As Long)
+  Call closesocket(hSock)
+  Sock = 0
+End Function
+
+' Daten senden
+Public Function SendData(ByVal Data As String) As Long
+  SendData = send(hSock, ByVal Data, Len(Data), 0&)
+End Function
+
+' Sind Daten angekommen ?
+Public Function DataComeIn() As Long
+  Dim Tmpstr As String * 1
+ 
+  DataComeIn = recv(hSock, ByVal Tmpstr, Len(Tmpstr), MSG_PEEK)
+  If DataComeIn = -1 Then
+    DataComeIn = WSAGetLastError()
+  End If
+End Function
+
+' Daten ermitteln
+Public Function GetData() As String
+  Dim Tmpstr As String * 4096, Retval As Long
+ 
+  Retval = recv(hSock, ByVal Tmpstr, Len(Tmpstr), 0&)
+  GetData = Left$(Tmpstr, Retval)
+End Function
+ 
+' Fügen Sie diesen Code in eine Form mit einem Command-Button und einem
+' Textfeld ein
+ 
+
+Public Function StartWinSocket() As Long
+
+  Dim Retval As Long, WSD As WSAData
+ 
+  Retval = WSAStartup(&H202, WSD)
+  If Retval < 0 Then
+   StartWinSocket = -1
+  End If
+  
+   StartWinSocket = 0
+
+End Function
+
+
+Public Sub EndWinSocket()
+
+  Call Disconnect(hSock)
+  Call WSACleanup
+  
+End Sub
+
+
+Public Function ReceiveString(length) As String
+
+Dim resultString As String
+
+While Len(resultString) < length
+
+ While DataComeIn() = 0
+  DoEvents
+ Wend
+ 
+ resultString = resultString + GetData()
+ 
+Wend
+ReceiveString = resultString
+
+End Function

wgmaster/vba/MWaage.bas

@@ -0,0 +1,995 @@
+Option Compare Database
+Option Explicit
+
+Dim tcpConnectionKeepAlive As Boolean
+Dim tcpConnectionOpen As Boolean
+
+Sub WiegenInitialisieren()
+
+tcpConnectionOpen = False
+tcpConnectionKeepAlive = True
+
+End Sub
+
+Sub WiegenBeenden()
+
+If tcpConnectionOpen = True Then
+ EndWinSocket
+ tcpConnectionOpen = False
+End If
+
+
+End Sub
+  
+Function Wiegen(Optional Datum As Date, Optional zeit As Date, Optional Gewicht As Long, Optional Waagentext As String, Optional KeineIdentNummernErhöhung As Boolean) As Long
+
+Dim waagentyp1
+
+waagentyp1 = GetParameter("WAAGENTYP")
+
+Wiegen = -1
+
+If waagentyp1 = "TOLEDO" Then
+ Wiegen = WiegenToledo
+End If
+
+If waagentyp1 = "GASSNER" Then
+ Wiegen = WiegenGassner(Datum, zeit, Gewicht, Waagentext)
+End If
+
+If waagentyp1 = "SCHEMBER" Then
+ Wiegen = WiegenSchember
+End If
+
+If waagentyp1 = "SYSTEC" Then
+ Wiegen = WiegenSystec
+End If
+
+If waagentyp1 = "IT3000" Then
+ Wiegen = WiegenIt3000(Datum, zeit, Gewicht)
+End If
+
+If waagentyp1 = "IT3000A" Then
+ Wiegen = WiegenIt3000a(Datum, zeit, Gewicht, Waagentext, KeineIdentNummernErhöhung)
+End If
+
+If waagentyp1 = "L320" Then
+ Wiegen = L320(Datum, zeit, Gewicht, Waagentext)
+End If
+
+If waagentyp1 = "L246" Then
+ Wiegen = L246(Datum, zeit, Gewicht, Waagentext, KeineIdentNummernErhöhung)
+End If
+
+
+
+End Function
+
+
+Function WiegenToledo() As Long
+' Wolkersdorf, Haugsdorf
+
+Dim buff(0 To 11) As Integer
+Dim i, c As Integer
+Dim str1 As String
+
+' Send command "netto weight": "CP"
+Forms!FÜbernahme.send (Asc("C"))
+Forms!FÜbernahme.TheEvent = 0
+While Forms!FÜbernahme.TheEvent < 1
+ DoEvents
+Wend
+Forms!FÜbernahme!XComm.InBufferCount = 0
+Forms!FÜbernahme.send (Asc("P"))
+
+' Read whole response word: 12 Bytes
+While i < 12 And c <> -1
+ c = Forms!FÜbernahme.Receive()
+ buff(i) = c
+ i = i + 1
+Wend
+
+If c = -1 Then
+ WiegenToledo = -1
+ Exit Function
+Else
+'Number of read bytes OK
+ 
+ 'Check if format is OK
+ 
+ 'First byte: 02
+ If buff(0) <> 2 Then
+  WiegenToledo = -2
+  Exit Function
+ End If
+ 'Bytes 9 and 10: 'kg'
+ If buff(8) <> Asc("k") Then
+  WiegenToledo = -3
+  Exit Function
+ End If
+ If buff(9) <> Asc("g") Then
+  WiegenToledo = -3
+  Exit Function
+ End If
+ 'Bytes 11 and 12: 0D 0A (CRLF)
+ If buff(10) <> &HD Then
+  WiegenToledo = -4
+  Exit Function
+ End If
+ If buff(11) <> &HA Then
+  WiegenToledo = -5
+  Exit Function
+ End If
+ 
+ 'Convert weight to long value
+ str1 = ""
+ For i = 1 To 7
+  str1 = str1 + Chr(buff(i))
+ Next i
+ c = CLng(str1)
+ 
+ WiegenToledo = c
+ 
+End If
+
+
+End Function
+
+
+
+Function WiegenGassner(Datum As Variant, zeit As Variant, Gewicht As Long, Waagentext As Variant) As Long
+'im Moment nirgends
+
+Dim buff(0 To 99) As Integer
+Dim i, c As Integer
+Dim str1 As String
+Dim str2 As String
+Dim waagennummer As Long
+Dim speichernummer As Long
+
+' Send command "ENQ": 05h
+Forms!FÜbernahme!XComm.InBufferCount = 0
+Forms!FÜbernahme.send (&H5)
+Forms!FÜbernahme.TheEvent = 0
+
+' Read whole response word: 25 Bytes
+While i < 47 And c <> -1
+ c = Forms!FÜbernahme.Receive()
+ buff(i) = c
+ i = i + 1
+Wend
+
+'str1 = ""
+'For i = 0 To 46
+' str1 = str1 + Hex(buff(i)) + " "
+' str2 = str2 + Chr(buff(i))
+'Next i
+'MsgBox (str1 + Chr(10) + Chr(13) + str2)
+
+If c = -1 Then
+ WiegenGassner = -1
+ Exit Function
+Else
+'Number of read bytes OK
+ 
+ 'Check if format is OK
+ 
+ 'First byte: 02
+ If buff(0) <> 2 Then
+  WiegenGassner = -2
+  Exit Function
+ End If
+ 
+ 'Second byte: "E"/"S"  (" "..OK, "E" for Error)
+ If buff(1) <> Asc(" ") Then
+  WiegenGassner = -3
+  Exit Function
+ End If
+ 
+ 'Third byte: "S"/"M"
+ If buff(2) <> Asc("S") Then
+  WiegenGassner = -4
+  Exit Function
+ End If
+ 
+ 'Convert weight to long value
+ str1 = ""
+ For i = 0 To 6
+  str1 = str1 + Chr(buff(i + 17))
+ Next i
+ c = CLng(str1)
+ Gewicht = c
+ WiegenGassner = c
+ 
+ 'Convert weight to long value
+ str1 = ""
+ For i = 0 To 6
+  str1 = str1 + Chr(buff(i + 17))
+ Next i
+ c = CLng(str1)
+ Gewicht = c
+ WiegenGassner = c
+ 
+ 'Convert Waagennummer
+ str1 = ""
+ For i = 0 To 1
+  str1 = str1 + Chr(buff(i + 24))
+ Next i
+ c = CLng(str1)
+ waagennummer = c
+ 
+ 'Convert Speichernummer
+ str1 = ""
+ For i = 0 To 5
+  str1 = str1 + Chr(buff(i + 26))
+ Next i
+ c = CLng(str1)
+ speichernummer = c
+ 
+ 'Convert Datum
+ str1 = ""
+ For i = 0 To 7
+  str1 = str1 + Chr(buff(i + 32))
+ Next i
+ If IsDate(Mid(str1, 7, 2) + "." + Mid(str1, 5, 2) + "." + Mid(str1, 1, 4)) Then
+  Datum = DateValue(Mid(str1, 7, 2) + "." + Mid(str1, 5, 2) + "." + Mid(str1, 1, 4))
+ End If
+ 
+ 'Convert Zeit
+ str1 = ""
+ For i = 0 To 5
+  str1 = str1 + Chr(buff(i + 40))
+ Next i
+ If IsDate(Mid(str1, 1, 2) + ":" + Mid(str1, 3, 2) + ":" + Mid(str1, 5, 2)) Then
+  zeit = TimeValue(Mid(str1, 1, 2) + ":" + Mid(str1, 3, 2) + ":" + Mid(str1, 5, 2))
+ End If
+ Waagentext = "Waagennummer: " + Format(waagennummer) + "  Speichernummer: " + Format(speichernummer)
+ 
+End If
+
+
+End Function
+
+Function WiegenGassnerAlt() As Long
+'im Moment nirgends
+
+Dim buff(0 To 24) As Integer
+Dim i, c As Integer
+Dim str1 As String
+
+' Send command "ENQ": 05h
+Forms!FÜbernahme!XComm.InBufferCount = 0
+Forms!FÜbernahme.send (&H5)
+Forms!FÜbernahme.TheEvent = 0
+
+' Read whole response word: 25 Bytes
+While i < 25 And c <> -1
+ c = Forms!FÜbernahme.Receive()
+ buff(i) = c
+ i = i + 1
+Wend
+
+If c = -1 Then
+ WiegenGassnerAlt = -1
+ Exit Function
+Else
+'Number of read bytes OK
+ 
+ 'Check if format is OK
+ 
+ 'First byte: 02
+ If buff(0) <> 2 Then
+  WiegenGassnerAlt = -2
+  Exit Function
+ End If
+ 
+ 'Second byte: "E"/"S"  (" "..OK, "E" for Error)
+ If buff(1) <> " " Then
+  WiegenGassnerAlt = -3
+  Exit Function
+ End If
+ 
+ 'Third byte: "S"/"M"
+ If buff(2) <> "S" Then
+  WiegenGassnerAlt = -4
+  Exit Function
+ End If
+  
+ 'Byte 25
+ 'If buff(24) <> &H3 Then
+ ' WiegenGassner = -5
+ ' Exit Function
+ 'End If
+ 
+ 'Convert weight to long value
+ str1 = ""
+ For i = 0 To 6
+  str1 = str1 + Chr(buff(i + 17))
+ Next i
+ c = CLng(str1)
+ 
+ WiegenGassnerAlt = c
+ 
+End If
+
+
+End Function
+
+
+
+Function WiegenSchember() As Long
+
+' Matzen
+
+Dim buff(0 To 24) As Integer
+Dim i, c As Integer
+Dim str1 As String
+
+' Send command "27,62"
+Forms!FÜbernahme.send (27)
+Forms!FÜbernahme.TheEvent = 0
+While Forms!FÜbernahme.TheEvent < 1
+ DoEvents
+Wend
+Forms!FÜbernahme.XComm.InBufferCount = 0
+Forms!FÜbernahme.send (62)
+
+' Read whole response word: 12 Bytes
+While i < 25 And c <> -1
+ c = Forms!FÜbernahme.Receive()
+ buff(i) = c
+ i = i + 1
+Wend
+
+If c = -1 Then
+ WiegenSchember = -1
+ Exit Function
+Else
+'Number of read bytes OK
+ 
+ 'Check if format is OK
+ 
+ 'First byte: 02
+ If buff(0) <> 2 Then
+  WiegenSchember = -2
+  Exit Function
+ End If
+
+ 'Bytes 11 and 12: 0D 0A (CRLF)
+ If buff(24) <> 3 Then
+  WiegenSchember = -4
+  Exit Function
+ End If
+
+ 'Convert weight to long value
+ str1 = ""
+ For i = 16 To 19
+  str1 = str1 + Chr(buff(i))
+ Next i
+ str1 = str1 + ","
+ str1 = str1 + Chr(buff(20))
+ c = CDbl(str1)
+ 
+ 
+ WiegenSchember = c
+ 
+End If
+
+
+End Function
+
+
+Function WiegenSystec() As Long
+
+' Matzen
+
+Dim buff(0 To 50) As Integer
+Dim i, c As Integer
+Dim str1 As String
+
+
+Forms!FÜbernahme.XComm.InBufferCount = 0
+
+'Wait for STX
+Do
+ c = Forms!FÜbernahme.Receive()
+Loop Until c = 2
+buff(0) = c
+
+i = 1
+While i < 17 And c <> -1
+ c = Forms!FÜbernahme.Receive()
+ buff(i) = c
+ i = i + 1
+Wend
+
+If c = -1 Then
+ WiegenSystec = -1
+ Exit Function
+Else
+
+'Number of read bytes OK
+ 
+'Check if format is OK
+ 
+ 'First byte: 02
+ If buff(0) <> 2 Then
+  WiegenSystec = -2
+  Exit Function
+ End If
+
+ 'Convert weight to long value
+ str1 = ""
+ For i = 4 To 9
+  str1 = str1 + Chr(buff(i))
+ Next i
+ c = CDbl(str1)
+ 
+ WiegenSystec = c
+ 
+End If
+
+
+End Function
+
+
+Function WiegenIt3000(Datum As Date, zeit As Date, Gewicht As Long) As Long
+' Röschitz
+
+Dim c As Integer
+Dim recordcount As Integer
+Dim record(0 To 20) As String
+
+'Receive STX
+While c <> 2 And c <> -1
+ c = Forms!FÜbernahme.Receive()
+Wend
+If c = -1 Then
+ WiegenIt3000 = -1
+ Forms!FÜbernahme.send (&H15) 'NAK
+ Exit Function
+End If
+'Receive Buffer and terminating ETX
+recordcount = 0
+record(recordcount) = ""
+While c <> -1 And c <> 3 'ETX
+ c = Forms!FÜbernahme.Receive()
+ If c = Asc(";") Or c = 3 Then
+  recordcount = recordcount + 1
+  record(recordcount) = ""
+ Else
+  If c <> -1 Then
+   record(recordcount) = record(recordcount) + Chr(c)
+  End If
+ End If
+Wend
+If c = -1 Then
+ WiegenIt3000 = -2
+ Forms!FÜbernahme.send (&H15) 'NAK
+ Exit Function
+End If
+
+'interpret records
+If recordcount < 4 Then
+ 'too less records
+ WiegenIt3000 = -3
+ Forms!FÜbernahme.send (&H15) 'NAK
+ Exit Function
+End If
+'record(0) is waagennummer
+Datum = DateValue(record(1))
+zeit = TimeValue(record(2))
+Gewicht = Val(record(3))
+
+'send acknowledge
+Forms!FÜbernahme.send (6) 'ACK
+
+Forms!FÜbernahme!XComm.InBufferCount = 0
+
+
+End Function
+
+Function WiegenIt3000a(Datum As Date, zeit As Date, Gewicht As Long, Waagentext As String, KeineIdentNummernErhöhung As Boolean) As Long
+' Matzen, Wolkersdorf
+
+Dim c As Integer
+Dim i As Integer
+Dim Data As String
+Dim record As String
+Dim waagennummer As Long
+Dim speichernummer As Long
+
+Forms!FÜbernahme.XComm.InBufferCount = 0
+Forms!FÜbernahme.TheEvent = 0
+
+If KeineIdentNummernErhöhung = True Then
+'Send command
+ Forms!FÜbernahme.send (Asc("<"))
+ Forms!FÜbernahme.send (Asc("R"))
+ Forms!FÜbernahme.send (Asc("M"))
+ Forms!FÜbernahme.send (Asc(">"))
+Else
+'Send command
+ Forms!FÜbernahme.send (Asc("<"))
+ Forms!FÜbernahme.send (Asc("R"))
+ Forms!FÜbernahme.send (Asc("N"))
+ Forms!FÜbernahme.send (Asc(">"))
+End If
+
+'Receive record
+i = 0
+Data = ""
+While i < 64 And c <> -1
+ c = Forms!FÜbernahme.Receive()
+ If c <> -1 Then
+  Data = Data + Chr(c)
+ End If
+ i = i + 1
+Wend
+
+'MsgBox (data)
+
+'skip < and >
+Data = Mid(Data, 2, 62)
+
+
+If c = -1 Then
+ WiegenIt3000a = -1
+ Exit Function
+End If
+
+'interpret data
+'1. Fehlercode, Waagenstatus
+record = Left(Data, 4)
+Data = Mid(Data, 5)
+If record <> "0000" Then
+ WiegenIt3000a = -2
+ Exit Function
+End If
+'2. Date
+record = Left(Data, 8)
+Data = Mid(Data, 9)
+If IsDate(record) Then
+ Datum = DateValue(record)
+Else
+ WiegenIt3000a = -3
+ Exit Function
+End If
+'2. Time
+record = Left(Data, 5)
+record = record + ":00"
+Data = Mid(Data, 6)
+If IsDate(record) Then
+ zeit = TimeValue(record)
+Else
+ WiegenIt3000a = -4
+ Exit Function
+End If
+'4. Identnr
+record = Left(Data, 4)
+Data = Mid(Data, 5)
+speichernummer = Val(record)
+'5. Waagennr
+record = Left(Data, 1)
+Data = Mid(Data, 2)
+waagennummer = Val(record)
+'6. Brutto
+record = Left(Data, 8)
+Data = Mid(Data, 9)
+'7. Tara
+record = Left(Data, 8)
+Data = Mid(Data, 9)
+'8. Netto
+record = Left(Data, 8)
+Data = Mid(Data, 9)
+If IsNumeric(record) Then
+ Gewicht = Val(record)
+Else
+ WiegenIt3000a = -5
+ Exit Function
+End If
+'9. kg
+record = Left(Data, 2)
+Data = Mid(Data, 3)
+If record <> "kg" Then
+ WiegenIt3000a = -6
+ Exit Function
+End If
+
+'rest wird nicht ausgewertet
+ 
+Waagentext = "Waagenr: " + Format(waagennummer) + "  ID: " + Format(speichernummer)
+
+WiegenIt3000a = Gewicht
+
+End Function
+
+Sub testl320()
+
+Dim Datum As Date
+Dim zeit As Date
+Dim Gewicht As Long
+Dim Waagentext As String
+Dim chk As String
+Dim Data As String
+
+Data = " 17.04.14 12:58    2        72kg" + Chr(10)
+
+Data = Mid(Data, 2)
+Datum = CDate(Left(Data, 8))
+Data = Mid(Data, 10)
+zeit = CDate(Left(Data, 5))
+Data = Mid(Data, 7)
+Waagentext = Left(Data, 4)
+Data = Mid(Data, 6)
+Gewicht = CLng(Left(Data, 9))
+Data = Mid(Data, 11)
+chk = Left(Data, 2)
+
+MsgBox (Datum)
+MsgBox (zeit)
+MsgBox (Gewicht)
+MsgBox (Waagentext)
+
+End Sub
+
+
+Function L320(Datum As Date, zeit As Date, Gewicht As Long, Waagentext As String) As Long
+
+Dim c As Long
+Dim Data As String
+Dim chk As String
+Dim i As Integer
+Dim str1 As String
+'Receive record
+str1 = ""
+
+Data = ""
+
+c = Forms!FÜbernahme.Receive()
+str1 = Format(c)
+'Forms!FÜbernahme!XComm.InBufferCount
+If c = 32 Then
+ i = 1
+ Data = Data + Chr(c)
+Else
+ c = Forms!FÜbernahme.Receive()
+ str1 = str1 + "," + Format(c)
+ c = Forms!FÜbernahme.Receive()
+ str1 = str1 + "," + Format(c)
+ 'MsgBox (str1)
+ L320 = -9
+ Exit Function
+End If
+
+While i < 33 And c <> -1
+ c = Forms!FÜbernahme.Receive()
+ If c <> -1 Then
+  Data = Data + Chr(c)
+ End If
+ str1 = str1 + "," + Format(c)
+ i = i + 1
+Wend
+
+'1: 0x20
+'2-9: Date 17.04.14
+'10 0x20
+'11-15: Time 12:58
+'16: 0x20
+'17-20: wiegenr
+'21: 0x20
+'22-30: gewicht
+'31-32: kg
+'33: 0x0A
+'MsgBox (str1 + ":" + Format(Len(data)) + ":" & data)
+If Len(Data) >= 33 Then
+    Data = Mid(Data, 2)
+    Datum = CDate(Left(Data, 8))
+    Data = Mid(Data, 10)
+    zeit = CDate(Left(Data, 5))
+    Data = Mid(Data, 7)
+    Waagentext = Left(Data, 4)
+    Data = Mid(Data, 6)
+    Gewicht = CLng(Left(Data, 9))
+    Data = Mid(Data, 10)
+    chk = Left(Data, 2)
+    If chk <> "kg" Then
+     'MsgBox ("Fehler! Waagenrecord nicht korrekt")
+     L320 = -1
+    Else
+     L320 = Gewicht
+    End If
+Else
+ L320 = -9
+End If
+
+
+End Function
+
+
+Function L246(Datum As Date, zeit As Date, Gewicht As Long, Waagentext As String, KeineIdentNummernErhöhung As Boolean) As Long
+
+' 1. open tcp port
+Dim host As String
+Dim tcpport As Long
+Dim result As Long
+
+If tcpConnectionOpen = False Then
+    host = GetParameter("WAAGEHOST")
+    tcpport = GetParameter("WAAGETCPPORT")
+    StartWinSocket
+    result = ConnectToServer(host, tcpport)
+    If result > 0 Then
+     tcpConnectionOpen = True
+    End If
+End If
+
+If tcpConnectionOpen = True Then
+     ' 2. send command
+     If (KeineIdentNummernErhöhung) Then
+      SendData "<RM1>"
+     Else
+      SendData "<RN1>"
+     End If
+    
+    ' 3. receive data
+    Dim response As String
+    
+    response = ReceiveString(65)
+    
+    ' 4. parse message
+    'MsgBox (response)
+    'Dim fehlerS As String
+    Dim datumS As String
+    Dim zeitS As String
+    Dim identNrS As String
+    Dim nettoS As String
+    Dim waagennummerS As String
+    Dim fehlerS As String
+    
+    fehlerS = Mid(response, 2, 2)
+    datumS = Mid(response, 6, 8)
+    zeitS = Mid(response, 14, 5)
+    identNrS = Mid(response, 19, 4)
+    waagennummerS = Mid(response, 23, 1)
+    nettoS = Mid(response, 40, 8)
+    
+    
+    If fehlerS <> "00" Then
+     MsgBox "Fehlermeldung Waage", vbCritical
+    End If
+    
+    Datum = CDate(datumS)
+    zeit = CDate(zeitS)
+    Waagentext = "Waagenr: " + Format(waagennummerS) + "  ID: " + Format(identNrS)
+    Gewicht = CLng(nettoS)
+    
+    'MsgBox (datum)
+    'MsgBox (zeit)
+    'MsgBox (waagentext)
+    'MsgBox (Gewicht)
+    
+    
+    ' 5. close port
+    If tcpConnectionKeepAlive = False Then
+     EndWinSocket
+     tcpConnectionOpen = False
+    End If
+End If
+
+
+End Function
+
+Function KippenL246(onoff As Boolean)
+
+Dim host As String
+Dim tcpport As Long
+Dim result As Long
+If tcpConnectionOpen = False Then
+    host = GetParameter("WAAGEHOST")
+    tcpport = GetParameter("WAAGETCPPORT")
+    StartWinSocket
+    result = ConnectToServer(host, tcpport)
+    If result > 0 Then
+     tcpConnectionOpen = True
+    End If
+End If
+
+If tcpConnectionOpen = True Then
+    ' 2. send command
+    If onoff Then
+     SendData "<OS02>"
+    Else
+     SendData "<OC02>"
+    End If
+    
+    ' 3. receive data
+    Dim response As String
+    
+    response = ReceiveString(5)
+    
+    ' 4. parse message
+    If Left(response, 4) <> "<00>" Then
+     MsgBox "Fehler beim Ansteuern des digitalen Ausganges", vbCritical
+    End If
+
+    ' 5. close port
+    If tcpConnectionKeepAlive = False Then
+     EndWinSocket
+     tcpConnectionOpen = False
+    End If
+    
+End If
+
+
+End Function
+
+
+Function FreigabeL246(onoff As Boolean)
+
+Dim host As String
+Dim tcpport As Long
+Dim result As Long
+
+If tcpConnectionOpen = False Then
+    host = GetParameter("WAAGEHOST")
+    tcpport = GetParameter("WAAGETCPPORT")
+    StartWinSocket
+    result = ConnectToServer(host, tcpport)
+    If result > 0 Then
+     tcpConnectionOpen = True
+    End If
+End If
+
+If tcpConnectionOpen = True Then
+    ' 2. send command
+    If onoff Then
+     SendData "<OS01>"
+    Else
+     SendData "<OC01>"
+    End If
+    
+    ' 3. receive data
+    Dim response As String
+    
+    response = ReceiveString(5)
+    
+    ' 4. parse message
+    If Left(response, 4) <> "<00>" Then
+     MsgBox "Fehler beim Ansteuern des digitalen Ausganges", vbCritical
+    End If
+    
+    ' 5. close port
+    If tcpConnectionKeepAlive = False Then
+     EndWinSocket
+     tcpConnectionOpen = False
+    End If
+End If
+
+End Function
+
+
+Sub TestL246()
+
+Dim Datum As Date
+Dim zeit As Date
+Dim Gewicht As Long
+Dim Waagentext As String
+
+WiegenInitialisieren
+L246 Datum, zeit, Gewicht, Waagentext, True
+L246 Datum, zeit, Gewicht, Waagentext, True
+L246 Datum, zeit, Gewicht, Waagentext, True
+KippenL246 (True)
+KippenL246 (False)
+WiegenBeenden
+
+
+End Sub
+
+
+
+Function Kippen(onoff As Boolean)
+
+Dim steuerungtyp1
+Dim extbefehl
+
+steuerungtyp1 = GetParameter("STEUERUNGTYP")
+
+If steuerungtyp1 = "SERIELL" Then
+ KippenSeriell (onoff)
+End If
+
+If steuerungtyp1 = "PARALLEL" Then
+ KippenParallel (onoff)
+End If
+
+
+If steuerungtyp1 = "L246" Then
+ KippenL246 (onoff)
+End If
+
+If steuerungtyp1 = "EXTERN" Then
+ extbefehl = GetParameter("STEUERUNGEXTERN")
+ If Not IsNull(extbefehl) And onoff = True Then
+  Shell extbefehl, vbMinimizedFocus
+ Else
+  MsgBox "Externes Programm nicht gefunden!", vbCritical
+ End If
+End If
+
+
+End Function
+
+
+
+Function KippenSeriell(onoff As Boolean)
+
+' Kippen: RTS Signal von COMx der Steuerung (i.a. COM2)
+' SubD 25: Pin 4, SubD 9: 7
+
+ Forms!FÜbernahme.XCommSteuerung.RTSEnable = onoff
+
+End Function
+
+
+Function KippenParallel(onoff As Boolean)
+
+' Kippen: Über Datenleitungen des Ports
+
+
+Dim port1
+Dim tport1
+Dim databyte As Byte
+
+port1 = GetParameter("STEUERUNGPORT")
+
+If Not IsNull(port1) Then
+
+ Select Case port1
+ 
+ Case "1": tport1 = "LPT1"
+
+ Case "2": tport1 = "LPT2"
+ 
+ Case "3": tport1 = "LPT3"
+
+ End Select
+ 
+End If
+
+If onoff = True Then
+  databyte = 255
+Else
+  databyte = 0
+End If
+
+Open tport1 For Binary Access Write As #1
+Put #1, , databyte
+
+Close #1
+
+End Function
+
+
+Function Freigabe(onoff As Boolean)
+
+Dim steuerungtyp1
+Dim extbefehl
+
+steuerungtyp1 = GetParameter("STEUERUNGTYP")
+
+If steuerungtyp1 = "L246" Then
+ FreigabeL246 (onoff)
+End If
+
+
+End Function
+
+
+Sub testkippen()
+
+KippenParallel (True)
+KippenParallel (False)
+
+End Sub

wgmaster/vba/Report_BAbschlaege.frm

@@ -0,0 +1,10 @@
+Option Compare Database
+Option Explicit
+
+Private Sub Report_Close()
+DoCmd.ShowToolbar "Datenbank", acToolbarNo
+End Sub
+
+Private Sub Report_Open(Cancel As Integer)
+DoCmd.ShowToolbar "Datenbank", acToolbarYes
+End Sub

wgmaster/vba/Report_BAbwertungen.frm

@@ -0,0 +1,10 @@
+Option Compare Database
+Option Explicit
+
+Private Sub Report_Close()
+DoCmd.ShowToolbar "Datenbank", acToolbarNo
+End Sub
+
+Private Sub Report_Open(Cancel As Integer)
+DoCmd.ShowToolbar "Datenbank", acToolbarYes
+End Sub

wgmaster/vba/Report_BAbwertungenMGNR.frm

@@ -0,0 +1,10 @@
+Option Compare Database
+Option Explicit
+
+Private Sub Report_Close()
+DoCmd.ShowToolbar "Datenbank", acToolbarNo
+End Sub
+
+Private Sub Report_Open(Cancel As Integer)
+DoCmd.ShowToolbar "Datenbank", acToolbarYes
+End Sub

wgmaster/vba/Report_BAbwertungenSorte.frm

@@ -0,0 +1,10 @@
+Option Compare Database
+Option Explicit
+
+Private Sub Report_Close()
+DoCmd.ShowToolbar "Datenbank", acToolbarNo
+End Sub
+
+Private Sub Report_Open(Cancel As Integer)
+DoCmd.ShowToolbar "Datenbank", acToolbarYes
+End Sub

wgmaster/vba/Report_BAnlieferungenJahresvergleichDetail.frm

@@ -0,0 +1,10 @@
+Option Compare Database
+Option Explicit
+
+Private Sub Report_Close()
+DoCmd.ShowToolbar "Datenbank", acToolbarNo
+End Sub
+
+Private Sub Report_Open(Cancel As Integer)
+DoCmd.ShowToolbar "Datenbank", acToolbarYes
+End Sub

wgmaster/vba/Report_BAnlieferungsbestaetigung.frm

@@ -0,0 +1,10 @@
+Option Compare Database
+Option Explicit
+
+Private Sub Report_Close()
+DoCmd.ShowToolbar "Datenbank", acToolbarNo
+End Sub
+
+Private Sub Report_Open(Cancel As Integer)
+DoCmd.ShowToolbar "Datenbank", acToolbarYes
+End Sub

wgmaster/vba/Report_BAnlieferungsbestaetigungMGNR.frm

@@ -0,0 +1,10 @@
+Option Compare Database
+Option Explicit
+
+Private Sub Report_Close()
+DoCmd.ShowToolbar "Datenbank", acToolbarNo
+End Sub
+
+Private Sub Report_Open(Cancel As Integer)
+DoCmd.ShowToolbar "Datenbank", acToolbarYes
+End Sub

wgmaster/vba/Report_BAuszahlung.frm

@@ -0,0 +1,29 @@
+Option Compare Database
+Option Explicit
+
+Private Sub Report_Close()
+DoCmd.ShowToolbar "Datenbank", acToolbarNo
+End Sub
+
+Private Sub Report_Open(Cancel As Integer)
+DoCmd.ShowToolbar "Datenbank", acToolbarYes
+End Sub
+
+Public Function Runden(value1 As Double, digits As Integer) As Double
+
+Dim temp1 As Double
+
+temp1 = value1 * (10 ^ digits)
+
+If (temp1 * 10) Mod 10 = 5 Then
+ temp1 = temp1 + 1
+ temp1 = Fix(temp1)
+ temp1 = temp1 / (10 ^ digits)
+ Runden = temp1
+Else
+ Runden = CLng(value1 * (10 ^ digits)) / (10 ^ digits)
+End If
+
+End Function
+
+

wgmaster/vba/Report_BAuszahlungMGNR.frm

@@ -0,0 +1,27 @@
+Option Compare Database
+Option Explicit
+
+Private Sub Report_Close()
+DoCmd.ShowToolbar "Datenbank", acToolbarNo
+End Sub
+
+Private Sub Report_Open(Cancel As Integer)
+DoCmd.ShowToolbar "Datenbank", acToolbarYes
+End Sub
+
+Public Function Runden(value1 As Double, digits As Integer) As Double
+
+Dim temp1 As Double
+
+temp1 = value1 * (10 ^ digits)
+
+If (temp1 * 10) Mod 10 = 5 Then
+ temp1 = temp1 + 1
+ temp1 = Fix(temp1)
+ temp1 = temp1 / (10 ^ digits)
+ Runden = temp1
+Else
+ Runden = CLng(value1 * (10 ^ digits)) / (10 ^ digits)
+End If
+
+End Function

wgmaster/vba/Report_BAuszahlungsvarianteKopf.frm

@@ -0,0 +1,10 @@
+Option Compare Database
+Option Explicit
+
+Private Sub Report_Close()
+DoCmd.ShowToolbar "Datenbank", acToolbarNo
+End Sub
+
+Private Sub Report_Open(Cancel As Integer)
+DoCmd.ShowToolbar "Datenbank", acToolbarYes
+End Sub

wgmaster/vba/Report_BAuszahlungsvarianteSorten.frm

@@ -0,0 +1,10 @@
+Option Compare Database
+Option Explicit
+
+Private Sub Report_Close()
+DoCmd.ShowToolbar "Datenbank", acToolbarNo
+End Sub
+
+Private Sub Report_Open(Cancel As Integer)
+DoCmd.ShowToolbar "Datenbank", acToolbarYes
+End Sub

wgmaster/vba/Report_BAuszahlungsvarianteSortenattribute.frm

@@ -0,0 +1,10 @@
+Option Compare Database
+Option Explicit
+
+Private Sub Report_Close()
+DoCmd.ShowToolbar "Datenbank", acToolbarNo
+End Sub
+
+Private Sub Report_Open(Cancel As Integer)
+DoCmd.ShowToolbar "Datenbank", acToolbarYes
+End Sub

wgmaster/vba/Report_BBanken.frm

@@ -0,0 +1,10 @@
+Option Compare Database
+Option Explicit
+
+Private Sub Report_Close()
+DoCmd.ShowToolbar "Datenbank", acToolbarNo
+End Sub
+
+Private Sub Report_Open(Cancel As Integer)
+DoCmd.ShowToolbar "Datenbank", acToolbarYes
+End Sub

wgmaster/vba/Report_BBehaelter.frm

@@ -0,0 +1,10 @@
+Option Compare Database
+Option Explicit
+
+Private Sub Report_Close()
+DoCmd.ShowToolbar "Datenbank", acToolbarNo
+End Sub
+
+Private Sub Report_Open(Cancel As Integer)
+DoCmd.ShowToolbar "Datenbank", acToolbarYes
+End Sub

wgmaster/vba/Report_BBewirtschaftungsarten.frm

@@ -0,0 +1,10 @@
+Option Compare Database
+Option Explicit
+
+Private Sub Report_Close()
+DoCmd.ShowToolbar "Datenbank", acToolbarNo
+End Sub
+
+Private Sub Report_Open(Cancel As Integer)
+DoCmd.ShowToolbar "Datenbank", acToolbarYes
+End Sub

wgmaster/vba/Report_BBuchungsliste.frm

@@ -0,0 +1,28 @@
+Option Compare Database
+Option Explicit
+
+Private Sub Report_Close()
+DoCmd.ShowToolbar "Datenbank", acToolbarNo
+End Sub
+
+Private Sub Report_Open(Cancel As Integer)
+DoCmd.ShowToolbar "Datenbank", acToolbarYes
+End Sub
+
+Public Function Runden(value1 As Double, digits As Integer) As Double
+
+Dim temp1 As Double
+
+temp1 = value1 * (10 ^ digits)
+
+If (temp1 * 10) Mod 10 = 5 Then
+ temp1 = temp1 + 1
+ temp1 = Fix(temp1)
+ temp1 = temp1 / (10 ^ digits)
+ Runden = temp1
+Else
+ Runden = CLng(value1 * (10 ^ digits)) / (10 ^ digits)
+End If
+
+End Function
+

wgmaster/vba/Report_BBuchungslisteBrutto.frm

@@ -0,0 +1,10 @@
+Option Compare Database
+Option Explicit
+
+Private Sub Report_Close()
+DoCmd.ShowToolbar "Datenbank", acToolbarNo
+End Sub
+
+Private Sub Report_Open(Cancel As Integer)
+DoCmd.ShowToolbar "Datenbank", acToolbarYes
+End Sub

wgmaster/vba/Report_BChargenListe.frm

@@ -0,0 +1,10 @@
+Option Compare Database
+Option Explicit
+
+Private Sub Report_Close()
+DoCmd.ShowToolbar "Datenbank", acToolbarNo
+End Sub
+
+Private Sub Report_Open(Cancel As Integer)
+DoCmd.ShowToolbar "Datenbank", acToolbarYes
+End Sub

wgmaster/vba/Report_BChargenStammblatt.frm

@@ -0,0 +1,10 @@
+Option Compare Database
+Option Explicit
+
+Private Sub Report_Close()
+DoCmd.ShowToolbar "Datenbank", acToolbarNo
+End Sub
+
+Private Sub Report_Open(Cancel As Integer)
+DoCmd.ShowToolbar "Datenbank", acToolbarYes
+End Sub

wgmaster/vba/Report_BChargenStammblattBehandlungen.frm

@@ -0,0 +1,10 @@
+Option Compare Database
+Option Explicit
+
+Private Sub Report_Close()
+DoCmd.ShowToolbar "Datenbank", acToolbarNo
+End Sub
+
+Private Sub Report_Open(Cancel As Integer)
+DoCmd.ShowToolbar "Datenbank", acToolbarYes
+End Sub

wgmaster/vba/Report_BChargenStammblattLieferungen.frm

@@ -0,0 +1,10 @@
+Option Compare Database
+Option Explicit
+
+Private Sub Report_Close()
+DoCmd.ShowToolbar "Datenbank", acToolbarNo
+End Sub
+
+Private Sub Report_Open(Cancel As Integer)
+DoCmd.ShowToolbar "Datenbank", acToolbarYes
+End Sub