Option Compare Database
Option Explicit

Sub GebundenBerechnen(Jahr1 As Long, SortenattributeBeiFlächenbindungOptional As Boolean, GebundenBerücksichtigen As Boolean)

 Dim db1 As Database
 Dim rs1 As Recordset
 Dim rs2 As Recordset
 Dim rs3 As Recordset

 Dim actMGNR As Long
 Dim actSNR As String
 Dim actSANR As String
 Dim rsSANR As String
 Dim actLieferrecht As Double
 Dim actLieferrecht_Attribute(0 To 255) As Double
 Dim actLieferungGebunden As Double
 Dim actBetrag As Double
 Dim GewichtGebunden As Double
 Dim GewichtGebundenGrundsorte As Double
 Dim test1
 
 
 Dim ErgebnisGewicht As Double
 Dim ErgebnisBetrag As Double
 Dim ErgebnisGebunden As Double
 Dim ErgebnisDatensaetze As Double
 Dim ErgebnisAktDatensatz As Double
 
 Dim query1 As String
 Dim query2 As String
 Dim zwi
 Dim maxertrag As Double
 Dim KgProHa
 Dim attribute_count As Long
 Dim i As Long
 Dim j As Long
 Dim ImmerUngebunden As Boolean
 
 
 
DoCmd.Hourglass True

 
 'maxertrag = GetParameter("MAXERTRAG")
 
 Set db1 = CurrentDb
   
 query1 = "SELECT * FROM TSorten INNER JOIN (TMitglieder INNER JOIN TLieferungen ON TMitglieder.MGNR = TLieferungen.MGNR) ON TSorten.SNR = TLieferungen.SNR WHERE Oechsle>0 AND TLieferungen.SNR>'' AND Year([Datum]) = " + Format(Jahr1) + " ORDER BY TLieferungen.MGNR, TLieferungen.SNR, TLieferungen.SANR DESC,  TLieferungen.LINR;"
 'query1 = "SELECT * FROM (TSorten INNER JOIN (TMitglieder INNER JOIN TLieferungen ON TMitglieder.MGNR = TLieferungen.MGNR) ON TSorten.SNR = TLieferungen.SNR) LEFT JOIN TSortenAttribute ON TLieferungen.SANR = TSortenAttribute.SANR WHERE Oechsle>0 AND TLieferungen.SNR>'' AND Year([Datum]) = " + Format(jahr1) + " ORDER BY TLieferungen.MGNR, TLieferungen.SNR, TLieferungen.SANR DESC,  TLieferungen.LINR;"
 Set rs1 = db1.OpenRecordset(query1)
 
 actMGNR = -1
 actSNR = ""
 actSANR = ""
 

 While Not rs1.EOF

  rs1.Edit
  
  If actMGNR <> rs1![TLieferungen.MGNR] Then
  ' Nächstes Mitglied
   actMGNR = rs1![TLieferungen.MGNR]
   actSNR = "----"
   actSANR = "----"
  End If
  
  If Not IsNull(rs1![SANR]) And rs1!SANR <> "" Then
   rsSANR = UCase(rs1![SANR])
   ImmerUngebunden = DFirst("ImmerUngebunden", "TSortenAttribute", "SANR='" + rsSANR + "'")
  Else
   rsSANR = ""
   ImmerUngebunden = False
  End If
  
  GewichtGebunden = 0
  GewichtGebundenGrundsorte = 0
  
  If SortenattributeBeiFlächenbindungOptional = True Then
      
      'A Sortenattribute in Flaechenbindung optional
        
      actSANR = rsSANR
      
      'Feststellen der Lieferrechte bei Sortenwechsel
      If actSNR <> UCase(rs1![TLieferungen.SNR]) Then
       
        actSNR = UCase(rs1![TLieferungen.SNR])
        
        KgProHa = DFirst("kgproHa", "TSorten", "SNR='" + actSNR + "'")
        
        'maxertrag für Grundsorte bestimmen
        If Not IsNull(KgProHa) And KgProHa > 0 Then
         maxertrag = KgProHa
        Else
         maxertrag = GetParameter("MAXERTRAG")
        End If
               
        'Lieferrecht für Grundsorte errechnen
        zwi = DSum("Flaeche", "TFlaechenbindungen", "MGNR=" + Format(actMGNR) + " AND SNR='" + Format(actSNR) + "' AND [Von]<=" + Format(Jahr1) + " AND (Bis>=" + Format(Jahr1) + " OR Isnull(Bis))")
        If IsNull(zwi) Then
         actLieferrecht = 0
         zwi = 0
        Else
         actLieferrecht = zwi * maxertrag / 10000
        End If
        
        'maxertrag für jedes Attribut bestimmen
        Set rs3 = db1.OpenRecordset("SELECT * FROM TSortenattribute ORDER BY SANR")
        i = 0
        While Not rs3.EOF
          KgProHa = rs3("kgproha")
         If Not IsNull(KgProHa) And KgProHa > 0 Then
          actLieferrecht_Attribute(i) = zwi * KgProHa / 10000
         Else
          actLieferrecht_Attribute(i) = zwi * GetParameter("MAXERTRAG") / 10000
         End If
         rs3.MoveNext
         i = i + 1
        Wend
        rs3.Close
        attribute_count = i
      End If
      
      
      If rs1!QSNR >= 3 And (rs1!gebunden = True Or GebundenBerücksichtigen = False) Then
       
       If actSANR = "" Then
         'Grundsorte
         
         If rs1!Gewicht < actLieferrecht Then
         ' Alles
           GewichtGebunden = rs1!Gewicht
           actLieferrecht = actLieferrecht - GewichtGebunden
           
           'auch für alle Attribute Lieferrecht reduzieren
           For i = 0 To attribute_count - 1
            actLieferrecht_Attribute(i) = actLieferrecht_Attribute(i) - GewichtGebunden
           Next i
           
         Else
          If actLieferrecht > 0 Then
           ' Ein Teil
           GewichtGebunden = actLieferrecht
           actLieferrecht = 0
           'auch für alle Attribute Lieferrecht reduzieren
           For i = 0 To attribute_count - 1
            actLieferrecht_Attribute(i) = actLieferrecht_Attribute(i) - GewichtGebunden
           Next i
          
          Else
           ' Kein geb. Lieferrecht mehr übrig
           GewichtGebunden = 0
          End If
         End If
       Else
         'Sortenattribut
         
         'Nur wenn Attribut nicht ohnehin Ungebunden
         If ImmerUngebunden = False Then
         
          'richtigen Eintrag finden
          Set rs3 = db1.OpenRecordset("SELECT * FROM TSortenattribute ORDER BY SANR")
          j = 0
          While Not rs3.EOF And rs3("SANR") <> actSANR
           rs3.MoveNext
           j = j + 1
          Wend
          rs3.Close
          If j > attribute_count Then
           'error
           MsgBox ("Fehler bei Attributen!")
          End If
          
          If rs1!Gewicht < actLieferrecht_Attribute(j) Then
          ' Alles
            GewichtGebunden = rs1!Gewicht
            actLieferrecht = actLieferrecht - GewichtGebunden
            
            'auch für alle Attribute Lieferrecht reduzieren
            For i = 0 To attribute_count - 1
             actLieferrecht_Attribute(i) = actLieferrecht_Attribute(i) - GewichtGebunden
            Next i
            
          Else
           If actLieferrecht_Attribute(j) > 0 Then
            ' Ein Teil
            GewichtGebunden = actLieferrecht_Attribute(j)
            'Lieferrecht bei Grundsorte reduzieren
            actLieferrecht = actLieferrecht - GewichtGebunden
            'auch für alle Attribute Lieferrecht reduzieren
            For i = 0 To attribute_count - 1
             actLieferrecht_Attribute(i) = actLieferrecht_Attribute(i) - GewichtGebunden
            Next i
            
           Else
            ' Kein geb. Lieferrecht mehr übrig
            GewichtGebunden = 0
           End If
          End If
          
          'Versuche, Rest auf Grundsorte zu verbuchen
          If GewichtGebunden < rs1!Gewicht And actLieferrecht > 0 Then
            
             If rs1!Gewicht - GewichtGebunden < actLieferrecht Then
             ' Alles
               GewichtGebundenGrundsorte = rs1!Gewicht - GewichtGebunden
               actLieferrecht = actLieferrecht - GewichtGebundenGrundsorte
               
               'auch für alle Attribute Lieferrecht reduzieren
               For i = 0 To attribute_count - 1
                actLieferrecht_Attribute(i) = actLieferrecht_Attribute(i) - GewichtGebundenGrundsorte
               Next i
               
             Else
              If actLieferrecht > 0 Then
               ' Ein Teil
               GewichtGebundenGrundsorte = actLieferrecht
               actLieferrecht = 0
               'auch für alle Attribute Lieferrecht reduzieren
               For i = 0 To attribute_count - 1
                actLieferrecht_Attribute(i) = actLieferrecht_Attribute(i) - GewichtGebundenGrundsorte
               Next i
              
              Else
               ' Kein geb. Lieferrecht mehr übrig
               GewichtGebundenGrundsorte = 0
              End If
             End If
            
            
          End If
        
        End If
        
       End If
      
      Else
       ' Kein Qualitätswein
       GewichtGebunden = 0
      End If
      
    
      'MsgBox (Format(rs1!Gewicht) + " " + Format(rs1!Gebunden) + " " + Format(GewichtGebunden))
    
      If IsNull(GewichtGebunden) Then GewichtGebunden = 0
      If IsNull(GewichtGebundenGrundsorte) Then GewichtGebundenGrundsorte = 0
      
      'rounding
      If CLng(GewichtGebunden) < GewichtGebunden Then
       GewichtGebunden = CLng(GewichtGebunden) + 1
      Else
       GewichtGebunden = CLng(GewichtGebunden)
      End If
      GewichtGebundenGrundsorte = Int(GewichtGebundenGrundsorte)
      
    
      rs1!BGewichtGebunden = GewichtGebunden
      rs1!BGewichtGebundenGrundsorte = GewichtGebundenGrundsorte
      
      rs1.Update
      
        
  Else
      'B Strikt = Sortenattribute in Flaechenbindung NICHT optional
      
      'Feststellen der Lieferrechte bei Sorten oder Attributswechsel
      If actSNR <> UCase(rs1![TLieferungen.SNR]) Or (actSANR <> rsSANR) Then
      ' Nächste Sorte oder Attribut
       actSNR = UCase(rs1![TLieferungen.SNR])
       actSANR = rsSANR
       
       'maxertrag setzen
       If actSANR <> "" Then
        'from Sortenattribut
            KgProHa = DFirst("kgproHa", "TSortenattribute", "SANR='" + rsSANR + "'")
            If Not IsNull(KgProHa) And KgProHa > 0 Then
             maxertrag = KgProHa
            Else
             maxertrag = GetParameter("MAXERTRAG")
            End If
         zwi = DSum("Flaeche", "TFlaechenbindungen", "MGNR=" + Format(actMGNR) + " AND SNR='" + Format(actSNR) + "' AND SANR='" + actSANR + "' AND [Von]<=" + Format(Jahr1) + " AND (Bis>=" + Format(Jahr1) + " OR Isnull(Bis))") * maxertrag / 10000
       Else
         'from Sorte
            If Not IsNull(rs1!KgProHa) And rs1!KgProHa > 0 Then
             maxertrag = rs1!KgProHa
            Else
             maxertrag = GetParameter("MAXERTRAG")
            End If
          zwi = DSum("Flaeche", "TFlaechenbindungen", "MGNR=" + Format(actMGNR) + " AND SNR='" + Format(actSNR) + "' AND (Isnull(SANR) or SANR='') AND [Von]<=" + Format(Jahr1) + " AND (Bis>=" + Format(Jahr1) + " OR Isnull(Bis))") * maxertrag / 10000
       End If
       
       
       If IsNull(zwi) Then
        actLieferrecht = 0
       Else
        actLieferrecht = zwi
       End If
       actLieferungGebunden = 0
      End If
      
      ' actLieferungGewicht
      
      
      
      'Wieviel ist gebunden ?
      
      
      If rs1!QSNR >= 3 And (rs1!gebunden = True Or GebundenBerücksichtigen = False) And ImmerUngebunden = False Then
      
       If rs1!Gewicht < actLieferrecht - actLieferungGebunden Then
       ' Alles
         GewichtGebunden = rs1!Gewicht
         actLieferungGebunden = actLieferungGebunden + GewichtGebunden
       Else
         If actLieferungGebunden < actLieferrecht Then
          ' Ein Teil
          GewichtGebunden = actLieferrecht - actLieferungGebunden
          actLieferungGebunden = actLieferrecht
         Else
          ' Kein geb. Lieferrecht mehr übrig
          GewichtGebunden = 0
         End If
       End If
      Else
       ' Kein Qualitätswein
       GewichtGebunden = 0
      End If
      
    
      'MsgBox (Format(rs1!Gewicht) + " " + Format(rs1!Gebunden) + " " + Format(GewichtGebunden))
    
      If IsNull(GewichtGebunden) Then GewichtGebunden = 0
      
      'round up
      If CLng(GewichtGebunden) < GewichtGebunden Then
       GewichtGebunden = CLng(GewichtGebunden) + 1
      Else
       GewichtGebunden = CLng(GewichtGebunden)
      End If
    
      rs1!BGewichtGebunden = GewichtGebunden
      rs1!BGewichtGebundenGrundsorte = 0
      rs1.Update
  
  End If

  rs1.MoveNext

 Wend

 rs1.Close



DoCmd.Hourglass False


End Sub




Sub Auszahlung2015_MwStUmstellen()

Dim db1 As Database
Dim rs1 As Recordset
Dim rs2 As Recordset
Dim faktor As Double
Dim Buchführend As Boolean
Dim summe1 As Double
Dim summe2 As Double


Set db1 = CurrentDb

'1. originaldaten sichern
db1.Execute ("DROP TABLE xTempLieferungen")
db1.Execute ("CREATE TABLE xTempLieferungen (LINR Integer, MGNR Integer, BTeilzahlung1 DOUBLE, BBetragGebunden DOUBLE, BBetragUngebunden DOUBLE,BTeilzahlung1_neu DOUBLE, BBetragGebunden_neu DOUBLE, BBetragUngebunden_neu DOUBLE, Korrekturbetrag DOUBLE,GesamtBrutto DOUBLE, GesamtBrutto_neu DOUBLE, GesamtBrutto_neu_korrigiert DOUBLE)")
db1.Execute ("DELETE * FROM xTempLieferungen")
Set rs1 = db1.OpenRecordset("SELECT * FROM TLieferungen where datum>Datevalue('01.01.2015') order by LINR")
Set rs2 = db1.OpenRecordset("xTempLieferungen")

While Not rs1.EOF
 rs2.AddNew
 rs2("LINR") = rs1("LINR")
 rs2("MGNR") = rs1("MGNR")
 rs2("BTeilzahlung1") = rs1("BTeilzahlung1")
 rs2("BBetragGebunden") = rs1("BBetragGebunden")
 rs2("BBetragUngebunden") = rs1("BBetragUngebunden")
 rs2.Update
 rs1.MoveNext
Wend
rs1.Close
rs2.Close

'2. nettobeträge korrigieren
Set rs1 = db1.OpenRecordset("SELECT TLieferungen.* FROM TLieferungen WHERE MGNR>0 AND datum>Datevalue('01.01.2015') order by LINR")
While Not rs1.EOF
 Buchführend = DFirst("Buchführend", "TMitglieder", "MGNR=" + Format(rs1("MGNR")))
 'If buchführend Then
 ' faktor = 1
 'Else
  faktor = 1.13 / 1.12
 'End If
 Set rs2 = db1.OpenRecordset("SELECT * FROM xTempLieferungen WHERE LINR=" + Format(rs1("LINR")))
 rs2.Edit
 rs2("BTeilzahlung1_neu") = rs1("BTeilzahlung1") * faktor
 rs2("BBetragGebunden_neu") = rs1("BBetragGebunden") * faktor
 rs2("BBetragUngebunden_neu") = rs1("BBetragUngebunden") * faktor
 rs2("Korrekturbetrag") = 0
 rs2.Update
 rs1.MoveNext
Wend
    rs1.Close
rs2.Close

'3. runden für gleichen Betrag
Set rs1 = db1.OpenRecordset("SELECT DISTINCT MGNR FROM TLieferungen WHERE MGNR>0 AND MGNR NOT IN (SELECT MGNR FROM TMitglieder WHERE Buchführend=True) AND datum>Datevalue('01.01.2015') order by MGNR")
While Not rs1.EOF
 
 summe1 = DSum("BTeilzahlung1", "xTempLieferungen", "MGNR=" + Format(rs1("MGNR")))
 summe2 = 0
 If summe1 <> 0 Then
    Set rs2 = db1.OpenRecordset("SELECT * FROM xTempLieferungen WHERE MGNR=" + Format(rs1("MGNR")))
 
    While Not rs2.EOF
     
     rs2.Edit
     rs2("BTeilzahlung1_neu") = Runden(rs2("BTeilzahlung1_neu"), 2)
     If Not IsNull(rs2("BBetragGebunden_neu")) Then
      rs2("BBetragGebunden_neu") = Runden(rs2("BBetragGebunden_neu"), 3)
     End If
     If Not IsNull(rs2("BBetragUngebunden_neu")) Then
      rs2("BBetragUngebunden_neu") = Runden(rs2("BBetragUngebunden_neu"), 3)
     End If
     summe2 = summe2 + rs2("BTEilzahlung1_neu")
     rs2.Update
     rs2.MoveNext
    Wend
    rs2.MovePrevious
    'letzten Eintrag auf korrekte Summe korrigieren
    rs2.Edit
    'rs2("Korrekturbetrag") = (summe2 * 1.12 - summe1 * 1.13) / 1.12
    rs2("Korrekturbetrag") = Runden((Runden(summe2 * 1.12, 2) - Runden(summe1 * 1.13, 2)) / 1.12, 2)
    rs2("GesamtBrutto") = Runden(summe1 * 1.13, 2)
    rs2("GesamtBrutto_neu") = Runden(summe2 * 1.12, 2)
    rs2("GesamtBrutto_neu_korrigiert") = Runden((summe2 - rs2("Korrekturbetrag")) * 1.12, 2)
    
    If rs2("GesamtBrutto_neu_korrigiert") > rs2("GesamtBrutto") Then
     rs2("Korrekturbetrag") = rs2("Korrekturbetrag") + 0.01
     rs2("GesamtBrutto_neu_korrigiert") = Runden((summe2 - rs2("Korrekturbetrag")) * 1.12, 2)
    End If
    If rs2("GesamtBrutto_neu_korrigiert") < rs2("GesamtBrutto") Then
     rs2("Korrekturbetrag") = rs2("Korrekturbetrag") - 0.01
     rs2("GesamtBrutto_neu_korrigiert") = Runden((summe2 - rs2("Korrekturbetrag")) * 1.12, 2)
    End If
    rs2.Update
    
    rs2.Close
    
 End If
 rs1.MoveNext
Wend
rs1.Close

'Exit Sub
'4. Rückübertragung in TLieferungen
Set rs1 = db1.OpenRecordset("SELECT * FROM xTempLieferungen WHERE BTeilzahlung1>0 ORDER BY LINR")
While Not rs1.EOF
 Set rs2 = db1.OpenRecordset("SELECT * FROM TLieferungen where LINR=" + Format(rs1("LINR")))
 If Not rs2.EOF Then
  rs2.Edit
  rs2("BTeilzahlung1") = Runden(rs1("BTeilzahlung1_neu") - rs1("Korrekturbetrag"), 2)
  rs2("BBetragGebunden") = rs1("BBetragGebunden_neu")
  rs2("BBetragUngebunden") = rs1("BBetragUngebunden_neu")
  rs2.Update
 End If
 rs2.Close
 rs1.MoveNext
Wend
rs1.Close

End Sub


Sub Auszahlung2015_NettoPreiseProKg_anheben()

Dim db1 As Database
Dim rs1 As Recordset

Dim faktor As Double

Set db1 = CurrentDb
faktor = 1.13 / 1.12
Set rs1 = db1.OpenRecordset("SELECT * FROM TAuszahlungSorten WHERE AZNR=140")
While Not rs1.EOF
rs1.Edit
If Not IsNull(rs1("Betrag")) Then
 rs1("Betrag") = Runden(faktor * rs1("Betrag"), 3)
End If
rs1.Update
rs1.MoveNext
Wend
rs1.Close

Set rs1 = db1.OpenRecordset("SELECT * FROM TAuszahlungSortenQualitätsstufe WHERE AZNR=140")
While Not rs1.EOF
rs1.Edit
If Not IsNull(rs1("Betrag")) Then
 rs1("Betrag") = Runden(faktor * rs1("Betrag"), 3)
End If
rs1.Update
rs1.MoveNext
Wend
rs1.Close



End Sub