Private Sub BAddieren_Click() Dim konst1 If Not IsNull(Forms!FAuszahlung!TSNR) Then konst1 = InputBox("Welchen Wert wollen Sie zu allen Qualitätszuschläge der ausgewählten Sorte addieren ?") If Not IsNull(konst1) Then Dim db1 As Database Dim rs1 As Recordset Set db1 = CurrentDb If IsNull(TSANR) Then Set rs1 = db1.OpenRecordset("SELECT * FROM TAuszahlungSorten WHERE AZNR=" + Format(Forms!FAuszahlung!TAZNR) + " AND SNR='" + Forms!FAuszahlung!TSNR + "' AND Gebunden=" + Format(Forms!FAuszahlung!TGebunden) + " AND Isnull(SANR)") Else Set rs1 = db1.OpenRecordset("SELECT * FROM TAuszahlungSorten WHERE AZNR=" + Format(Forms!FAuszahlung!TAZNR) + " AND SNR='" + Forms!FAuszahlung!TSNR + "' AND Gebunden=" + Format(Forms!FAuszahlung!TGebunden) + " AND SANR='" + TSANR + "'") End If While Not rs1.EOF rs1.Edit rs1!Betrag = rs1!Betrag + konst1 rs1.Update rs1.MoveNext Wend rs1.Close FUnter1.Requery End If End If End Sub Function GetFilter() Dim filter1 As String If IsNull(TZNR) Then filter1 = "Year(Datum)=" + Format(Forms!FAuszahlung!TLesejahr) Else filter1 = "Year(Datum)=" + Format(Forms!FAuszahlung!TLesejahr) + " AND ZNR=" + Forms!FAuszahlung!TZNR End If If Not IsNull(TVon) And Not IsNull(TBis) Then filter1 = filter1 + " AND " If OSortierung = 1 Then ' sort by mgnr filter1 = filter1 + "MGNR>=" + Format(TVon) + " AND MGNR<=" + Format(TBis) Else ' sort by plz filter1 = filter1 + "PLZ>='" + Format(TVon) + "' AND PLZ<= '" + Format(TBis) + "'" End If End If GetFilter = filter1 End Function Private Sub BAuszahlungDrucken_Click() Dim filter1 DoCmd.DoMenuItem acFormBar, acRecordsMenu, acSaveRecord, , acMenuVer70 If IsNull(TFusstext.Value) Then SetParameter "AUSZAHLUNGTEXT", " " Else SetParameter "AUSZAHLUNGTEXT", TFusstext.Value End If If IsNull(GetParameter("AUSZAHLUNGZUSATZTEXT_BF")) Then SetParameter "AUSZAHLUNGZUSATZTEXT_BF", " " End If If IsNull(GetParameter("AUSZAHLUNGZUSATZTEXT_PA")) Then SetParameter "AUSZAHLUNGZUSATZTEXT_PA", " " End If filter1 = GetFilter 'filter1 = "SELECT * FROM TLieferungen WHERE " + filter1 'MsgBox (getfilter) DoCmd.Maximize Select Case OSortierung Case 1: DoCmd.OpenReport "BAuszahlungMGNR", acPreview, , filter1 Case 2: DoCmd.OpenReport "BAuszahlung", acPreview, , filter1 End Select End Sub Private Sub BBerechnen_Click() If IsNull(TLesejahr) Or TLesejahr < 1900 Then MsgBox ("Bitte zuerst das Lesejahr eingeben !") TLesejahr.SetFocus Exit Sub End If Select Case Forms!FAuszahlung!TZahlungNr Case 1: If DSum("BTeilzahlung1", "TLieferungen", "Year(Datum)=" + Format(TLesejahr)) Then If MsgBox("Es wurde für dieses Lesejahr bereits eine 1.Teilzahlung berechnet ! Fortfahren ?", vbYesNo) = vbNo Then Exit Sub End If End If Case 2: If DSum("BTeilzahlung2", "TLieferungen", "Year(Datum)=" + Format(TLesejahr)) Then If MsgBox("Es wurde für dieses Lesejahr bereits eine 2.Teilzahlung berechnet ! Fortfahren ?", vbYesNo) = vbNo Then Exit Sub End If End If Case 3: If DSum("BTeilzahlung3", "TLieferungen", "Year(Datum)=" + Format(TLesejahr)) Then If MsgBox("Es wurde für dieses Lesejahr bereits eine 3.Teilzahlung berechnet ! Fortfahren ?", vbYesNo) = vbNo Then Exit Sub End If End If Case 4: If DSum("BTeilzahlung4", "TLieferungen", "Year(Datum)=" + Format(TLesejahr)) Then If MsgBox("Es wurde für dieses Lesejahr bereits eine 4.Teilzahlung berechnet ! Fortfahren ?", vbYesNo) = vbNo Then Exit Sub End If End If Case 5: If DSum("BTeilzahlung5", "TLieferungen", "Year(Datum)=" + Format(TLesejahr)) Then If MsgBox("Es wurde für dieses Lesejahr bereits eine 5.Teilzahlung berechnet ! Fortfahren ?", vbYesNo) = vbNo Then Exit Sub End If End If Case 6: If DSum("BEndauszahlung", "TLieferungen", "Year(Datum)=" + Format(TLesejahr)) Then If MsgBox("Es wurde für dieses Lesejahr bereits eine Endauszahlung berechnet ! Fortfahren ?", vbYesNo) = vbNo Then Exit Sub End If End If End Select If MsgBox("Dieser Vorgang kann länger dauern ! Fortfahren ?", vbYesNo) = vbYes Then DoCmd.Hourglass True '1. Gebunden/Gebunden Grundsorte/Ungebunden bestimmen GebundenBerechnen TLesejahr, OSortenAttributInFlaechenbindungOptional, OGebunden '2. Berechnen der Tarife f. alle Lieferungen Dim db1 As Database Dim rs1 As Recordset Dim rs2 As Recordset Dim rs3 As Recordset Dim GewichtGebunden As Double Dim GewichtGebundenGrundsorte As Double Dim ErgebnisGewicht As Double Dim ErgebnisBetrag As Double Dim ErgebnisGebunden As Double Dim ErgebnisDatensaetze As Double Dim ErgebnisAktDatensatz As Double Dim GB As Double ' Grundbetrag Dim GZS As Double ' Gebundenzuschlag Dim GZS_SQ As Double ' Gebundenzuschlag sorten/qualitätsabhängig Dim SQZS As Double ' Sorten/Qualitätszuschlag Dim QSZS As Double 'Qualitätsstufenzuschlag Dim GZS_SQ_Grundsorte As Double Dim SQZS_Grundsorte As Double Dim ZSZS As Double ' Zweigstellenzuschlag Dim RIZS As Double ' Riedzuschlag Dim GEZS As Double ' Gemeindezuschlag Dim GRZS As Double ' Großlagenzuschlag Dim WEZS As Double ' Weinbaugebietszuschlag Dim REZS As Double ' Regionzuschlag Dim REBELFAKT As Double Dim AZAS As Double ' Abschläge Dim BetragProKgUngebunden As Double Dim BetragProKgGebunden As Double Dim BetragProKgGebundenGrundsorte As Double Dim query1 As String Dim query2 As String Dim gesamtpunkte_gebunden As Double Dim gesamtpunkte_ungebunden As Double Dim gesamtpunkte_gebunden_grundsorte As Double Dim actBetrag As Double Set db1 = CurrentDb query1 = "SELECT * FROM TSorten INNER JOIN (TMitglieder INNER JOIN TLieferungen ON TMitglieder.MGNR = TLieferungen.MGNR) ON TSorten.SNR = TLieferungen.SNR WHERE Oechsle>0 AND TLieferungen.SNR>'' AND Year([Datum]) = " + Format(Forms!FAuszahlung!TLesejahr) + " ORDER BY TLieferungen.MGNR, TLieferungen.SNR, TLieferungen.SANR DESC, TLieferungen.LINR" Set rs1 = db1.OpenRecordset(query1) 'Lieferungen If IsNull(TGB) Then GB = 0 Else GB = TGB End If If IsNull(TGBZS) Then GZS = 0 Else GZS = TGBZS End If ErgebnisGewicht = 0 ErgebnisBetrag = 0 ErgebnisGebunden = 0 ErgebnisDatensaetze = 0 ErgebnisAktDatensatz = 0 While Not rs1.EOF ZSZS = 0 RIZS = 0 GEZS = 0 GRZS = 0 WEZS = 0 REZS = 0 rs1.Edit ' Gebunden GewichtGebunden = rs1("BGewichtGebunden") GewichtGebundenGrundsorte = rs1("BGewichtGebundenGrundsorte") ' Qualitätsstufenzuschlag 'If rs1("LINR") = 178227 Then ' MsgBox ("Lieferung gefunden") 'End If If IsNull(rs1("SANR")) Or rs1("SANR") = "" Then query2 = "SELECT Betrag AS QSZS,TAuszahlungSortenQualitätsstufe.SNR,TAuszahlungSortenQualitätsstufe.SANR FROM TAuszahlungSortenQualitätsstufe INNER JOIN TLieferungen ON (TAuszahlungSortenQualitätsstufe.SNR = TLieferungen.SNR AND TAuszahlungSortenQualitätsstufe.QSNR=TLieferungen.QSNR) WHERE (TAuszahlungSortenQualitätsstufe.SANR IS NULL or TAuszahlungSortenQualitätsstufe.SANR='') AND AZNR=" + Format(Forms!FAuszahlung!TAZNR) + " AND TLieferungen.LINR=" + Format(rs1("LINR")) 'query2 = "SELECT Betrag AS QSZS,TAuszahlungSortenQualitätsstufe.SNR,TAuszahlungSortenQualitätsstufe.SANR FROM TAuszahlungSortenQualitätsstufe INNER JOIN TLieferungen ON (TAuszahlungSortenQualitätsstufe.SNR = TLieferungen.SNR AND TAuszahlungSortenQualitätsstufe.QSNR=TLieferungen.QSNR) WHERE TAuszahlungSortenQualitätsstufe.SANR IS NULL AND AZNR=" + Format(Forms!FAuszahlung!TAZNR) + " AND TLieferungen.LINR=" + Format(rs1("LINR")) Else query2 = "SELECT Betrag AS QSZS, TAuszahlungSortenQualitätsstufe.SNR, TAuszahlungSortenQualitätsstufe.SANR FROM TAuszahlungSortenQualitätsstufe INNER JOIN TLieferungen ON (TAuszahlungSortenQualitätsstufe.SNR = TLieferungen.SNR AND TAuszahlungSortenQualitätsstufe.QSNR=TLieferungen.QSNR AND TAuszahlungSortenQualitätsstufe.SANR=TLieferungen.SANR) WHERE AZNR=" + Format(Forms!FAuszahlung!TAZNR) + " AND TLieferungen.LINR=" + Format(rs1("LINR")) End If Set rs2 = db1.OpenRecordset(query2) ' Falls ein Qualitätsstufenzuschlag gefunden wird, wird der Sorten & Qualitätszuschlag nicht angewendet! If Not rs2.EOF Then '1. Qualitätsstufenzuschlag gefunden rs2.MoveLast 'If rs2(1) = "BP" And IsNull(rs1("SANR")) Then ' MsgBox (rs2.recordcount) ' MsgBox (rs2(2)) 'End If QSZS = rs2("QSZS") rs2.Close SQZS = 0 SQZS_Grundsorte = 0 'Kein Gebundenzuschlag GZS = 0 GZS_SQ = 0 Else QSZS = 0 rs2.Close '2. Kein Qualitätsstufenzuschlag gefunden ' Sorten- und Qualitätszuschlag anwenden 'Anfrage für genau diese Sorte und OriginalOechsle und ungebunden If IsNull(rs1("SANR")) Or rs1("SANR") = "" Then query2 = "SELECT TAuszahlungSorten.Betrag AS SQZS, TLieferungen.LINR FROM TAuszahlungSorten INNER JOIN TLieferungen ON (TAuszahlungSorten.Oechsle = TLieferungen.Oechsle) AND (TAuszahlungSorten.SNR = TLieferungen.SNR) WHERE TAuszahlungSorten.AZNR=" + Format(Forms!FAuszahlung!TAZNR) + " AND TAuszahlungSorten.gebunden=False AND TLieferungen.LINR=" + Format(rs1("LINR")) + " AND (Isnull(TAuszahlungSorten.SANR) or TAuszahlungSorten.SANR='')" Else query2 = "SELECT TAuszahlungSorten.Betrag AS SQZS, TLieferungen.LINR FROM TAuszahlungSorten INNER JOIN TLieferungen ON (TAuszahlungSorten.Oechsle = TLieferungen.Oechsle) AND (TAuszahlungSorten.SNR = TLieferungen.SNR) AND (TAuszahlungSorten.SANR = TLieferungen.SANR) WHERE TAuszahlungSorten.AZNR=" + Format(Forms!FAuszahlung!TAZNR) + " AND TAuszahlungSorten.gebunden=False AND TLieferungen.LINR=" + Format(rs1("LINR")) End If Set rs2 = db1.OpenRecordset(query2) If rs2.EOF Then MsgBox "FEHLER! Kein Auszahlungswert für Lieferschein " + Format(rs1("Lieferscheinnummer")) + ", Sorte=" + rs1("TLieferungen.SNR") + ", Oechsle=" + Format(rs1("Oechsle")) + " gefunden (ungebunden)! Berechnung wird abgebrochen!", vbCritical rs2.Close rs1.Close Exit Sub End If SQZS = rs2!SQZS 'DFirst("Betrag", "SELECT * FROM TAuszahlungSorten", "SNR='" + rs1!SNR + "' AND Oechlse=" + Format(rs1!Oechsle) + " AND AZNR=" + Format(TAZNR)) rs2.MoveLast If rs2.recordcount > 1 Then MsgBox "FEHLER! Mehr als Auszahlungswert für Lieferschein " + Format(rs1("Lieferscheinnummer")) + ", Sorte=" + rs1("TLieferungen.SNR") + ", Oechsle=" + Format(rs1("Oechsle")) + " gefunden! Berechnung wird abgebrochen!", vbCritical rs2.Close rs1.Close Exit Sub End If rs2.Close 'Grundsorte query2 = "SELECT TAuszahlungSorten.Betrag AS SQZS, TLieferungen.LINR FROM TAuszahlungSorten INNER JOIN TLieferungen ON (TAuszahlungSorten.Oechsle = TLieferungen.Oechsle) AND (TAuszahlungSorten.SNR = TLieferungen.SNR) WHERE TAuszahlungSorten.AZNR=" + Format(Forms!FAuszahlung!TAZNR) + " AND TAuszahlungSorten.gebunden=False AND TLieferungen.LINR=" + Format(rs1("LINR")) + " AND (Isnull(TAuszahlungSorten.SANR) or TAuszahlungSorten.SANR='')" Set rs2 = db1.OpenRecordset(query2) If rs2.EOF Then MsgBox "FEHLER! Kein Auszahlungswert für Lieferschein " + Format(rs1("Lieferscheinnummer")) + ", Sorte=" + rs1("TLieferungen.SNR") + ", Oechsle=" + Format(rs1("Oechsle")) + " gefunden (ungebunden)! Berechnung wird abgebrochen!", vbCritical rs2.Close rs1.Close Exit Sub End If SQZS_Grundsorte = rs2!SQZS 'DFirst("Betrag", "SELECT * FROM TAuszahlungSorten", "SNR='" + rs1!SNR + "' AND Oechlse=" + Format(rs1!Oechsle) + " AND AZNR=" + Format(TAZNR)) rs2.MoveLast If rs2.recordcount > 1 Then MsgBox "FEHLER! Mehr als Auszahlungswert für Lieferschein " + Format(rs1("Lieferscheinnummer")) + ", Sorte=" + rs1("TLieferungen.SNR") + ", Oechsle=" + Format(rs1("Oechsle")) + " gefunden! Berechnung wird abgebrochen!", vbCritical rs2.Close rs1.Close Exit Sub End If rs2.Close ' Gebundenzuschlag Sorten/Qualitätsabhängig 'Anfrage für genau diese Sorte und Oechsle und gebunden If IsNull(rs1("SANR")) Or rs1("SANR") = "" Then query2 = "SELECT TAuszahlungSorten.Betrag AS SQZS, TLieferungen.LINR FROM TAuszahlungSorten INNER JOIN TLieferungen ON (TAuszahlungSorten.Oechsle = TLieferungen.Oechsle) AND (TAuszahlungSorten.SNR = TLieferungen.SNR) WHERE TAuszahlungSorten.AZNR=" + Format(Forms!FAuszahlung!TAZNR) + " AND TAuszahlungSorten.gebunden=True AND TLieferungen.LINR=" + Format(rs1("LINR")) + " AND (Isnull(TAuszahlungSorten.SANR) or TAuszahlungSorten.SANR='')" Else query2 = "SELECT TAuszahlungSorten.Betrag AS SQZS, TLieferungen.LINR FROM TAuszahlungSorten INNER JOIN TLieferungen ON (TAuszahlungSorten.Oechsle = TLieferungen.Oechsle) AND (TAuszahlungSorten.SNR = TLieferungen.SNR) AND (TAuszahlungSorten.SANR = TLieferungen.SANR) WHERE TAuszahlungSorten.AZNR=" + Format(Forms!FAuszahlung!TAZNR) + " AND TAuszahlungSorten.gebunden=True AND TLieferungen.LINR=" + Format(rs1("LINR")) End If Set rs2 = db1.OpenRecordset(query2) If rs2.EOF Then MsgBox "FEHLER! Kein Auszahlungswert für Lieferschein " + Format(rs1("Lieferscheinnummer")) + ", Sorte=" + rs1(SNR) + ", Oechsle=" + Format(rs1("Oechsle")) + " gefunden (gebunden)! Berechnung wird abgebrochen!", vbCritical rs2.Close rs1.Close Exit Sub End If GZS_SQ = rs2!SQZS 'DFirst("Betrag", "SELECT * FROM TAuszahlungSorten", "SNR='" + rs1!SNR + "' AND Oechlse=" + Format(rs1!Oechsle) + " AND AZNR=" + Format(TAZNR)) rs2.MoveLast If rs2.recordcount > 1 Then MsgBox "FEHLER! Mehr als Auszahlungswert für Lieferschein " + Format(rs1("Lieferscheinnummer")) + ", Sorte=" + rs1("TLieferungen.SNR") + ", Oechsle=" + Format(rs1("Oechsle")) + " gefunden (gebunden)! Berechnung wird abgebrochen!", vbCritical rs2.Close rs1.Close Exit Sub End If rs2.Close GZS_SQ = GZS_SQ - SQZS 'Grundsorte query2 = "SELECT TAuszahlungSorten.Betrag AS SQZS, TLieferungen.LINR FROM TAuszahlungSorten INNER JOIN TLieferungen ON (TAuszahlungSorten.Oechsle = TLieferungen.Oechsle) AND (TAuszahlungSorten.SNR = TLieferungen.SNR) WHERE TAuszahlungSorten.AZNR=" + Format(Forms!FAuszahlung!TAZNR) + " AND TAuszahlungSorten.gebunden=True AND TLieferungen.LINR=" + Format(rs1("LINR")) + " AND (Isnull(TAuszahlungSorten.SANR) or TAuszahlungSorten.SANR='')" Set rs2 = db1.OpenRecordset(query2) If rs2.EOF Then MsgBox "FEHLER! Kein Auszahlungswert für Lieferschein " + Format(rs1("Lieferscheinnummer")) + ", Sorte=" + rs1(SNR) + ", Oechsle=" + Format(rs1("Oechsle")) + " gefunden (gebunden)! Berechnung wird abgebrochen!", vbCritical rs2.Close rs1.Close Exit Sub End If GZS_SQ_Grundsorte = rs2!SQZS 'DFirst("Betrag", "SELECT * FROM TAuszahlungSorten", "SNR='" + rs1!SNR + "' AND Oechlse=" + Format(rs1!Oechsle) + " AND AZNR=" + Format(TAZNR)) rs2.MoveLast If rs2.recordcount > 1 Then MsgBox "FEHLER! Mehr als Auszahlungswert für Lieferschein " + Format(rs1("Lieferscheinnummer")) + ", Sorte=" + rs1("TLieferungen.SNR") + ", Oechsle=" + Format(rs1("Oechsle")) + " gefunden (gebunden)! Berechnung wird abgebrochen!", vbCritical rs2.Close rs1.Close Exit Sub End If rs2.Close GZS_SQ_Grundsorte = GZS_SQ_Grundsorte - SQZS_Grundsorte End If If OZWZS Then ' Zweigstellenzuschlag: ZNR ist nicht Stammzweigstelle des Mitglieds If rs1![TMitglieder.ZNR] <> rs1![TLieferungen.ZNR] Then ZSZS = DFirst("ZSZS", "TZweigstellen", "ZNR=" + Format(rs1![TLieferungen.ZNR])) End If End If If ORIZS Then ' Riedzuschlag If Not IsNull(rs1!RNR) Then RIZS = DFirst("RZS", "TRiede", "RNR=" + Format(rs1!RNR)) End If End If If OGEZS Then ' Gemeindezuschlag If Not IsNull(rs1!GNR) Then GEZS = DFirst("GZS", "TGemeinden", "GNR=" + Format(rs1!GNR)) End If End If If OGRZS Then ' Großlagenzuschlag If Not IsNull(rs1!GNR) Then query1 = "SELECT * FROM TGrosslagen INNER JOIN TGemeinden ON TGrosslagen.GLNR = TGemeinden.GLNR WHERE GNR=" + Format(rs1!GNR) Set rs3 = db1.OpenRecordset(query1) GRZS = rs3!GLZS rs3.Close End If End If If OWEZS Then ' Gebietszuschlag If Not IsNull(rs1!GNR) Then query1 = "SELECT * FROM TGebiete INNER JOIN (TGrosslagen INNER JOIN TGemeinden ON TGrosslagen.GLNR = TGemeinden.GLNR) ON TGebiete.WBGNR = TGrosslagen.WBGNR WHERE GNR=" + Format(rs1!GNR) Set rs3 = db1.OpenRecordset(query1) WEZS = rs3!WBGZS rs3.Close End If End If If OREZS Then ' Regionzuschlag If Not IsNull(rs1!GNR) Then query1 = "SELECT * FROM TRegionen INNER JOIN (TGebiete INNER JOIN (TGrosslagen INNER JOIN TGemeinden ON TGrosslagen.GLNR = TGemeinden.GLNR) ON TGebiete.WBGNR = TGrosslagen.WBGNR) ON TRegionen.RGNR = TGebiete.RGNR WHERE GNR=" + Format(rs1!GNR) Set rs3 = db1.OpenRecordset(query1) REZS = rs3!RZS rs3.Close End If End If 'Volllieferantenzuschlag If rs1!Volllieferant = True Then VLZS = TAufschlagVolllieferant 'MsgBox (rs1![TMitglieder.MGNR]) If IsNull(VLZS) Then VLZS = 0 Else VLZS = 0 End If REBELFAKT = 1 ' Gerebelt bzw. Rebelfaktor If IsNull(TRebelzuschlag) Then TRebelzuschlag = 0 rs1!BRebelzuschlag = 0 If Not IsNull(TRebelzuschlag) And rs1!Gerebelt = True Then REBELFAKT = (100 + TRebelzuschlag) / 100 rs1!BRebelzuschlag = TRebelzuschlag End If 'Zu-/Abschläge absolut If OAZAS Then query1 = "SELECT TAbschlaege.* FROM TAbschlaege INNER JOIN TLieferungAbschlag ON TAbschlaege.ASNR = TLieferungAbschlag.ASNR WHERE LINR=" + Format(rs1!LINR) AZAS = 0 Set rs3 = db1.OpenRecordset(query1) While Not rs3.EOF If Not IsNull(rs3!AZAS) Then AZAS = AZAS + rs3!AZAS End If rs3.MoveNext Wend rs3.Close End If ' Berechnung der Beträge pro kg 'If GZS < 0 Or GZS_SQ < 0 Then ' MsgBox ("GZS oder GZS_SQ<0") ' MsgBox (rs1!LINR) 'End If BetragProKgUngebunden = (GB + QSZS + SQZS + ZSZS + RIZS + GEZS + GRZS + WEZS + REZS + VLZS + AZAS) '2.1.2012: Falls Qualitätsstufenzuschlag zum Tragen kommt gibt es keinen gebundenen Tarif. If QSZS > 0 Then BetragProKgGebunden = 0 Else BetragProKgGebunden = BetragProKgUngebunden + GZS + GZS_SQ End If BetragProKgGebundenGrundsorte = (GB + SQZS_Grundsorte + ZSZS + RIZS + GEZS + GRZS + WEZS + REZS + VLZS + AZAS) + GZS + GZS_SQ_Grundsorte 'Zu-/Abschläge % ABSCHLAGFAKTOR = 1 If OAZAS Then query1 = "SELECT TAbschlaege.* FROM TAbschlaege INNER JOIN TLieferungAbschlag ON TAbschlaege.ASNR = TLieferungAbschlag.ASNR WHERE LINR=" + Format(rs1!LINR) Set rs3 = db1.OpenRecordset(query1) While Not rs3.EOF If Not IsNull(rs3!AZASProzent) Then ABSCHLAGFAKTOR = ABSCHLAGFAKTOR * (100 + rs3!AZASProzent) / 100 End If rs3.MoveNext Wend rs3.Close End If BetragProKgUngebunden = BetragProKgUngebunden * ABSCHLAGFAKTOR BetragProKgGebunden = BetragProKgGebunden * ABSCHLAGFAKTOR BetragProKgGebundenGrundsorte = BetragProKgGebundenGrundsorte * ABSCHLAGFAKTOR gesamtpunkte_gebunden = BetragProKgGebunden gesamtpunkte_gebunden_grundsorte = BetragProKgGebundenGrundsorte gesamtpunkte_ungebunden = BetragProKgUngebunden ' Berücksichtigung des Ausgabefaktors If IsNull(TAusgabefaktor) Then TAusgabefaktor = 1 BetragProKgUngebunden = BetragProKgUngebunden * TAusgabefaktor BetragProKgGebunden = BetragProKgGebunden * TAusgabefaktor BetragProKgGebundenGrundsorte = BetragProKgGebundenGrundsorte * TAusgabefaktor ' Rundung der Beträge pro kg BetragProKgUngebunden = Runden(BetragProKgUngebunden, 3) BetragProKgGebunden = Runden(BetragProKgGebunden, 3) BetragProKgGebundenGrundsorte = Runden(BetragProKgGebundenGrundsorte, 3) ' Berechnung von actBetrag If Not IsNull(rs1!Gewicht) Then actBetrag = (rs1!Gewicht - GewichtGebunden - GewichtGebundenGrundsorte) * REBELFAKT * BetragProKgUngebunden + REBELFAKT * GewichtGebunden * BetragProKgGebunden + REBELFAKT * GewichtGebundenGrundsorte * BetragProKgGebundenGrundsorte Else actBetrag = 0 End If 'actBetrag Runden 'rs1!BProbeauszahlung = actBetrag actBetrag = Runden(actBetrag, 2) ' Berechnete Felder aktualisieren If IsNull(rs1!BTeilzahlung1) Then rs1!BTeilzahlung1 = 0 End If If IsNull(rs1!BTeilzahlung2) Then rs1!BTeilzahlung2 = 0 End If If IsNull(rs1!BTeilzahlung3) Then rs1!BTeilzahlung3 = 0 End If If IsNull(rs1!BTeilzahlung4) Then rs1!BTeilzahlung4 = 0 End If If IsNull(rs1!BTeilzahlung5) Then rs1!BTeilzahlung5 = 0 End If Select Case Forms!FAuszahlung!TZahlungNr Case 1: rs1!BTeilzahlung1 = actBetrag Case 2: rs1!BTeilzahlung2 = actBetrag Case 3: rs1!BTeilzahlung3 = actBetrag Case 4: rs1!BTeilzahlung4 = actBetrag Case 5: rs1!BTeilzahlung5 = actBetrag Case 6: rs1!BEndauszahlung = actBetrag Case 7: rs1!BProbeauszahlung = actBetrag End Select 'BAbschlaegestring updaten rs1!BAbschlaegeString = GetAbschlägeAsString(rs1!LINR) 'Gesamtpunkteanzahl If TAusgabefaktor <> 1 Then 'nur wenn Ausgabefaktor ungleich 1 If (GewichtGebunden = rs1!Gewicht) Then 'alles Gebunden rs1!BAbschlaegeString = Format(gesamtpunkte_gebunden) + " Punkte/kg " + rs1!BAbschlaegeString Else If (GewichtGebunden = 0) Then 'alles ungebunden rs1!BAbschlaegeString = Format(gesamtpunkte_ungebunden) + " Punkte/kg " + rs1!BAbschlaegeString Else rs1!BAbschlaegeString = Format(gesamtpunkte_gebunden) + "/" + Format(gesamtpunkte_ungebunden) + " Punkte/kg " + rs1!BAbschlaegeString End If End If End If 'rs1!BGewichtGebunden = GewichtGebunden rs1!BBetragUngebunden = BetragProKgUngebunden rs1!BBetragGebunden = BetragProKgGebunden rs1!BBetragGebundenGrundsorte = BetragProKgGebundenGrundsorte ' BetragGebunden pro kg test1 = rs1!Lieferscheinnummer rs1.Update ' Ausgabe der laufenden Ergebnisse If Not IsNull(rs1!Gewicht) Then ErgebnisGewicht = ErgebnisGewicht + rs1!Gewicht End If ErgebnisBetrag = ErgebnisBetrag + actBetrag ErgebnisGebunden = ErgebnisGebunden + GewichtGebunden + GewichtGebundenGrundsorte ErgebnisDatensaetze = rs1.recordcount ErgebnisAktDatensatz = ErgebnisAktDatensatz + 1 If ErgebnisAktDatensatz Mod 10 = 0 Then TErgebnisGewicht = ErgebnisGewicht TErgebnisBetrag = ErgebnisBetrag TErgebnisGebunden = ErgebnisGebunden TErgebnisDatensaetze = ErgebnisDatensaetze TErgebnisAktDatensatz = ErgebnisAktDatensatz DoEvents End If rs1.MoveNext Wend rs1.Close End If TErgebnisGewicht = ErgebnisGewicht TErgebnisBetrag = ErgebnisBetrag TErgebnisGebunden = ErgebnisGebunden TErgebnisDatensaetze = ErgebnisDatensaetze TErgebnisAktDatensatz = ErgebnisAktDatensatz DoCmd.Hourglass False End Sub Private Sub Befehl285_Click() DoCmd.DoMenuItem acFormBar, acRecordsMenu, acSaveRecord, , acMenuVer70 DoCmd.Maximize DoCmd.OpenReport "BUeberweisungsliste", acViewPreview End Sub Private Sub Befehl286_Click() DoCmd.DoMenuItem acFormBar, acRecordsMenu, acSaveRecord, , acMenuVer70 DoCmd.Maximize DoCmd.OpenReport "BBuchungsliste", acViewPreview End Sub Private Sub Befehl301_Click() MsgBox (OGebunden) End Sub Private Sub BExportExcel_Click() Dim SEL1 As String Dim GROUP1 As String Dim where1 As String Dim order1 As String Dim query1 Dim savepath1 DoCmd.DoMenuItem acFormBar, acRecordsMenu, acSaveRecord, , acMenuVer70 SEL1 = "SELECT DISTINCT TMitglieder.MGNR, TMitglieder.Nachname, TMitglieder.Vorname, TMitglieder.Straße, TMitglieder.PLZ, TMitglieder.Ort, TMitglieder.KontoNr, TMitglieder.BLZ, TBanken.Name1 AS Bank, TMitglieder.BHKontonummer, CCur(Sum(IIf([Formulare]![FAuszahlung]![TZahlungNr]=1,[BTeilzahlung1],IIf([Formulare]![FAuszahlung]![TZahlungNr]=2,[BTeilzahlung2],IIf([Formulare]![FAuszahlung]![TZahlungNr]=3,[BTeilzahlung3],IIf([Formulare]![FAuszahlung]![TZahlungNr]=4,[BTeilzahlung4],IIf([Formulare]![FAuszahlung]![TZahlungNr]=5,[BTeilzahlung5],IIf([Formulare]![FAuszahlung]![TZahlungNr]=6,[BEndauszahlung],[BProbeauszahlung])))))))) AS BetragNetto, First(IIf([Buchführend],Getparameter('MWST2'),GetPArameter('MWST1'))) AS MwStProzent, CCur(BetragNetto*MwStProzent/100) as MwStBetrag, CCur(BetragNetto*(MwStProzent+100)/100) as BetragBrutto" SEL1 = SEL1 + " FROM TBanken RIGHT JOIN (TMitglieder RIGHT JOIN TLieferungen ON TMitglieder.MGNR = TLieferungen.MGNR) ON TBanken.BLZ = TMitglieder.BLZ " GROUP1 = " GROUP BY TMitglieder.MGNR, TMitglieder.Nachname, TMitglieder.Vorname, TMitglieder.Straße, TMitglieder.PLZ, TMitglieder.Ort, TMitglieder.KontoNr, TMitglieder.BLZ, TBanken.Name1, TMitglieder.BHKontonummer " Select Case OSortierung Case 1: order1 = " ORDER BY TMitglieder.MGNR " Case 2: order1 = " ORDER BY TMitglieder.PLZ, TMitglieder.Ort, TMitglieder.Nachname, TMitglieder.Vorname " End Select where1 = " WHERE Year(Datum)=" + Format(TLesejahr) + " AND Storniert=false " If Not IsNull(TZNR) And TZNR <> "" Then where1 = where1 + " AND TLieferungen.ZNR=" + Format(TZNR) End If If Not IsNull(TVon) And TVon >= 0 Then If OSortierung = 1 Then where1 = where1 + " AND TLieferungen.MGNR>=" + Format(TVon) + " " Else where1 = where1 + " AND TMitglieder.PLZ>=" + Format(TVon) + " " End If End If If Not IsNull(TBis) And TBis >= 0 Then If OSortierung = 1 Then where1 = where1 + " AND TLieferungen.MGNR<=" + Format(TBis) + " " Else where1 = where1 + " AND TMitglieder.PLZ<=" + Format(TBis) + " " End If End If query1 = SEL1 + where1 + GROUP1 + order1 savepath1 = InputBox("Excel Datei speichern unter:", "EXCEL DATEI EXPORTIEREN", "C:\Eigene Dateien\auszahlung.xls") If IsNull(savepath) Or savepath1 = "" Then Exit Sub End If DoCmd.Hourglass True queryname1 = "AAuszahlungExport" Dim db1 As Database Set db1 = CurrentDb On Error Resume Next DoCmd.DeleteObject acQuery, queryname1 'MsgBox (query1) db1.CreateQueryDef queryname1, query1 db1.Close DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel5, queryname1, savepath1, True DoCmd.Hourglass False End Sub Private Sub BExport_Click() DoCmd.DoMenuItem acFormBar, acRecordsMenu, acSaveRecord, , acMenuVer70 DoCmd.OpenForm "MExportAuszahlung" End Sub Private Sub BGebunden_Click() Dim konst1 Dim minoechsle konst1 = InputBox("Welchen Wert wollen Sie zu allen 'Gebunden'-Qualitätszuschlägen addieren ?") If Not IsNull(konst1) And konst1 <> "" Then Dim db1 As Database Dim rs1 As Recordset Set db1 = CurrentDb minoechsle = DFirst("Von", "TQualitaetsstufen", "QSNR=3") Set rs1 = db1.OpenRecordset("SELECT * FROM TAuszahlungSorten WHERE AZNR=" + Format(Forms!FAuszahlung!TAZNR) + " AND gebunden=true AND Oechsle>=" + Format(minoechsle)) While Not rs1.EOF rs1.Edit rs1!Betrag = rs1!Betrag + konst1 rs1.Update rs1.MoveNext Wend rs1.Close FUnter1.Requery End If End Sub Private Sub BKonstant_Click() Dim konst1 If Not IsNull(Forms!FAuszahlung!TSNR) Then konst1 = InputBox("Auf welchen Wert wollen Sie alle Qualitätszuschläge der ausgewählten Sorte setzen ?") If Not IsNull(konst1) And konst1 <> "" Then Dim db1 As Database Dim rs1 As Recordset Set db1 = CurrentDb If IsNull(TSANR) Then Set rs1 = db1.OpenRecordset("SELECT * FROM TAuszahlungSorten WHERE AZNR=" + Format(Forms!FAuszahlung!TAZNR) + " AND SNR='" + Forms!FAuszahlung!TSNR + "' AND Gebunden=" + Format(Forms!FAuszahlung!TGebunden) + " AND Isnull(SANR)") Else Set rs1 = db1.OpenRecordset("SELECT * FROM TAuszahlungSorten WHERE AZNR=" + Format(Forms!FAuszahlung!TAZNR) + " AND SNR='" + Forms!FAuszahlung!TSNR + "' AND Gebunden=" + Format(Forms!FAuszahlung!TGebunden) + " AND SANR='" + TSANR + "'") End If While Not rs1.EOF rs1.Edit rs1!Betrag = konst1 rs1.Update rs1.MoveNext Wend rs1.Close FUnter1.Requery End If End If End Sub Private Sub BKopieren_Click() If Not IsNull(Forms!FAuszahlung!TSNR) Then DoCmd.OpenForm "FAuszahlungSortenAuswahl" End If End Sub Private Sub BParameter_Click() If Not IsNull(Forms!FAuszahlung!TSNR) Then DoCmd.OpenForm "FAuszahlungParameter", acNormal End If End Sub Private Sub BUngebundenGebunden_Click() If MsgBox("Wollen Sie alle ungebundenen Sorten/Qualitätszuschläge auf die entsprechenden gebundenen Sorten/Qualitätszuschläge übertragen ?", vbYesNo) = vbYes Then Dim db1 As Database Dim rs1 As Recordset Dim rs2 As Recordset Set db1 = CurrentDb Set rs1 = db1.OpenRecordset("SELECT * FROM TAuszahlungSorten WHERE AZNR=" + Format(Forms!FAuszahlung!TAZNR) + " AND Gebunden=False") While Not rs1.EOF If IsNull(rs1("SANR")) Then Set rs2 = db1.OpenRecordset("SELECT * FROM TAuszahlungSorten WHERE AZNR=" + Format(Forms!FAuszahlung!TAZNR) + " AND SNR='" + rs1!SNR + "' And Oechsle=" + Format(rs1!Oechsle) + " AND Gebunden=True AND SANR=Null") Else Set rs2 = db1.OpenRecordset("SELECT * FROM TAuszahlungSorten WHERE AZNR=" + Format(Forms!FAuszahlung!TAZNR) + " AND SNR='" + rs1!SNR + "' And Oechsle=" + Format(rs1!Oechsle) + " AND Gebunden=True AND SANR='" + Format(rs1!SANR) + "'") End If If Not rs2.EOF Then rs2.Edit rs2!Betrag = rs1!Betrag rs2.Update rs2.Close End If rs1.MoveNext Wend rs1.Close FUnter1.Requery End If End Sub Private Sub BVonVorigerTeilauszahlung_Click() NummerierungVonVorigerAuszahlungFortsetzen End Sub Sub NummerierungVonVorigerAuszahlungFortsetzen() BerechneErsteNummer BerechneLetzteNummer End Sub Sub BerechneErsteNummer() Dim maxNumber 'Erste Nummer bestimmen maxNumber = DMax("TraubengutschriftNummerBis", "TAuszahlung", "Lesejahr=" + Format(TLesejahr) + " AND TraubengutschriftenNummerieren=True AND AZNR<>" + Format(TAZNR) + " AND TeilzahlungNr<" + Format(TZahlungNr)) If Not IsNull(maxNumber) Then TTraubengutschriftNummerVon = maxNumber + 1 Else TTraubengutschriftNummerVon = 1 End If End Sub Sub BerechneLetzteNummer() Dim db1 As Database Dim rs1 As Recordset 'Letzte Nummer bestimmen Set db1 = CurrentDb Set rs1 = db1.OpenRecordset("SELECT DISTINCT TMitglieder.MGNR FROM TSorten INNER JOIN (TMitglieder INNER JOIN TLieferungen ON TMitglieder.MGNR = TLieferungen.MGNR) ON TSorten.SNR = TLieferungen.SNR WHERE Oechsle>0 AND TLieferungen.SNR>'' AND Year([Datum]) = " + Format(Forms!FAuszahlung!TLesejahr)) rs1.MoveLast TTraubengutschriftNummerBis = TTraubengutschriftNummerVon + rs1.recordcount - 1 rs1.Close End Sub Private Sub Form_Open(Cancel As Integer) OSortierung = 1 TFusstext = GetParameter("AUSZAHLUNGTEXT") 'TZNR = 1 TGebunden = 0 If OTraubengutschriftenNummerieren Then XNummernkreisRahmen.Visible = True TTraubengutschriftNummerVon.Visible = True TTraubengutschriftNummerBis.Visible = True BVonVorigerTeilauszahlung.Visible = True Else XNummernkreisRahmen.Visible = False TTraubengutschriftNummerVon.Visible = False TTraubengutschriftNummerBis.Visible = False BVonVorigerTeilauszahlung.Visible = False End If End Sub Private Sub OTraubengutschriftenNummerieren_Click() If OTraubengutschriftenNummerieren Then XNummernkreisRahmen.Visible = True TTraubengutschriftNummerVon.Visible = True TTraubengutschriftNummerBis.Visible = True BVonVorigerTeilauszahlung.Visible = True Else XNummernkreisRahmen.Visible = False TTraubengutschriftNummerVon.Visible = False TTraubengutschriftNummerBis.Visible = False BVonVorigerTeilauszahlung.Visible = False TTraubengutschriftNummerVon = "" TTraubengutschriftNummerBis = "" End If End Sub Private Sub TFusstext_Exit(Cancel As Integer) If Not IsNull(TFusstext.Value) And TFusstext.Value <> "" Then SetParameter "AUSZAHLUNGTEXT", TFusstext.Value Else SetParameter "AUSZAHLUNGTEXT", " " End If End Sub Private Sub TGBZS_Exit(Cancel As Integer) MsgBox ("Für gebundene und ungebundene Lieferungen gibt es auch unterschiedliche Sortentabellen pro Oechsle. Unterschiede zwischen gebundenen und ungebundenen Auszahlungen sollten daher in die Sortentabellen eingebracht werden. Das Feld 'Gebunden-Zuschlag' einer Auszahlung ist daher grundsätzlich obsolet, wird aber aus Kompatibilitätsgründen weiterhin bei der Berechnung berücksichtigt.") End Sub Private Sub TGebunden_Click() FUnter1.Requery End Sub Private Sub TGebunden_Exit(Cancel As Integer) FUnter1.Requery End Sub Private Sub TSANR_Click() If Not IsNull(TSANR) Then FUnter1.Form.RecordSource = "SELECT * FROM TAuszahlungSorten WHERE TAuszahlungSorten.SNR=[Forms]![FAuszahlung]![TSNR] AND TAuszahlungSorten.gebunden=[Forms]![FAuszahlung]![TGebunden] AND TAuszahlungSorten.SANR=[Forms]![FAuszahlung]![TSANR] ORDER BY TAuszahlungSorten.Oechsle" Else FUnter1.Form.RecordSource = "SELECT * FROM TAuszahlungSorten WHERE TAuszahlungSorten.SNR=[Forms]![FAuszahlung]![TSNR] AND TAuszahlungSorten.gebunden=[Forms]![FAuszahlung]![TGebunden] AND TAuszahlungSorten.SANR IS NULL ORDER BY TAuszahlungSorten.Oechsle" End If FUnter1.Requery End Sub Private Sub TSNR_Click() FUnter1.Requery End Sub Private Sub TSNR_Exit(Cancel As Integer) FUnter1.Requery End Sub Private Sub TTraubengutschriftNummerVon_Exit(Cancel As Integer) BerechneLetzteNummer End Sub Private Sub TZahlungNr_Change() Dim str1 As String Dim str2 As String Select Case Forms!FAuszahlung!TZahlungNr Case 1: If DSum("BTeilzahlung1", "TLieferungen", "Year(Datum)=" + Format(TLesejahr)) Then If MsgBox("Es wurde für dieses Lesejahr bereits eine 1.Teilzahlung berechnet ! Fortfahren ?", vbYesNo) = vbNo Then Forms!FAuszahlung!TZahlungNr = 7 End If End If Case 2: If DSum("BTeilzahlung2", "TLieferungen", "Year(Datum)=" + Format(TLesejahr)) Then If MsgBox("Es wurde für dieses Lesejahr bereits eine 2.Teilzahlung berechnet ! Fortfahren ?", vbYesNo) = vbNo Then Forms!FAuszahlung!TZahlungNr = 7 End If End If Case 3: If DSum("BTeilzahlung3", "TLieferungen", "Year(Datum)=" + Format(TLesejahr)) Then If MsgBox("Es wurde für dieses Lesejahr bereits eine 3.Teilzahlung berechnet ! Fortfahren ?", vbYesNo) = vbNo Then Forms!FAuszahlung!TZahlungNr = 7 End If End If Case 4: If DSum("BTeilzahlung4", "TLieferungen", "Year(Datum)=" + Format(TLesejahr)) Then If MsgBox("Es wurde für dieses Lesejahr bereits eine 4.Teilzahlung berechnet ! Fortfahren ?", vbYesNo) = vbNo Then Forms!FAuszahlung!TZahlungNr = 7 End If End If Case 5: If DSum("BTeilzahlung5", "TLieferungen", "Year(Datum)=" + Format(TLesejahr)) Then If MsgBox("Es wurde für dieses Lesejahr bereits eine frei definierbare Zahlung berechnet ! Fortfahren ?", vbYesNo) = vbNo Then Forms!FAuszahlung!TZahlungNr = 7 End If End If If IsNull(GetParameter("FREIERAUSZAHLUNGSTITEL")) Then str1 = "" Else str1 = GetParameter("FREIERAUSZAHLUNGSTITEL") str2 = "" End If While str2 = "" str2 = InputBox("Bitte geben Sie den freien Auszahlungstitel ein:", "FREIER TITEL", str1) Wend SetParameter "FREIERAUSZAHLUNGSTITEL", str2 Case 6: If DSum("BEndauszahlung", "TLieferungen", "Year(Datum)=" + Format(TLesejahr)) Then If MsgBox("Es wurde für dieses Lesejahr bereits eine Endauszahlung berechnet ! Fortfahren ?", vbYesNo) = vbNo Then Forms!FAuszahlung!TZahlungNr = 7 End If End If End Select End Sub Private Sub TZahlungNr_Exit(Cancel As Integer) If TZahlungNr.Value = 6 Then OEndauszahlung = True Else OEndauszahlung = False End If End Sub Private Sub Befehl283_Click() Dim query As String 'DoCmd.OpenReport "BAuszahlungsvariante", acViewPreview DoCmd.OpenQuery "AAuszahlungsvarianten" DoCmd.Maximize DoCmd.OpenReport "BAuszahlungsvarianteKopf", acViewPreview End Sub Sub ErgebnisfelderLoeschen() TErgebnisBetrag = "" TErgebnisGewicht = "" TErgebnisGebunden = "" TErgebnisDatensaetze = "" End Sub Function RundenAlt(Wert As Double, KommaStellen As Integer) As Double Dim t1 As Double t1 = CLng(Wert * 10 ^ KommaStellen) / 10 ^ KommaStellen 't1 = Round(Wert, KommaStellen) RundenAlt = t1 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 Function GetAbschlägeAsString(LINR1 As Long) As String Const separator = " / " Const separator_length = 3 Dim db1 As Database Dim rs1 As Recordset Dim resultString As String Set db1 = CurrentDb Set rs1 = db1.OpenRecordset("SELECT TAbschlaege.* FROM (TLieferungAbschlag INNER JOIN TAbschlaege ON TLieferungAbschlag.ASNR = TAbschlaege.ASNR) INNER JOIN TLieferungen ON TLieferungAbschlag.LINR = TLieferungen.LINR WHERE TLieferungen.LINR=" + Format(LINR1)) resultString = "" While Not rs1.EOF resultString = resultString + separator + rs1!Bezeichnung rs1.MoveNext Wend rs1.Close If resultString <> "" Then resultString = Mid(resultString, 1 + separator_length) GetAbschlägeAsString = resultString End Function