Move wgmaster/vba/Form_* to wgmaster/vba/form/*

wgmaster/vba/form/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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