HTML:
Sub Comprimeren()
gstr1 = "Deze functie maakt de huidige administratie kleiner, door de boekingen van elke rekening tot 1 regel terug te brengen."
gstr1 = gstr1 + vbNewLine & "Daardoor geven de functies REKENINGKAARTEN weinig informatie meer."
gstr1 = gstr1 + vbNewLine & "Wil je dit?"
If MsgBox(gstr1, vbYesNo, "Comprimeren") = 7 Then Exit Sub
jaar = Contact("Haal", "mmo", "SELECT * FROM H_Pointers WHERE id=2")
If Val(jaar) < 2000 Then MsgBox "Ga eerst naar parameters en voer het huidig boekjaar in ": Exit Sub
Set Tabel1 = CurrentDb.OpenRecordset("select * from t_grootboek where reknr<10000"): Gint2 = 0
Tabel1.MoveFirst
Do Until Tabel1.EOF
gstr1 = "SELECT T_Boekingen.*, T_Grootboek.RekNr, T_Grootboek.Groepsrekening"
gstr1 = gstr1 & " FROM T_Boekingen INNER JOIN T_Grootboek ON T_Boekingen.RekNr = T_Grootboek.RekNr WHERE (T_Grootboek.RekNr)=" & Tabel1!RekNr & ";"
Set tabel2 = CurrentDb.OpenRecordset(gstr1):
Set tabel3 = CurrentDb.OpenRecordset("T_Boekingen")
If tabel2.RecordCount = 0 Then GoTo Verder
Gcur1 = 0: tabel2.MoveFirst
For Gint1 = 1 To tabel2.RecordCount
If tabel2!DC = "D" Then Gcur1 = Gcur1 + tabel2!Bedrag Else Gcur1 = Gcur1 - tabel2!Bedrag
gstr1 = "delete T_Boekingen.* From T_Boekingen WHERE T_Boekingen.RekNr = " & Tabel1!RekNr & " and T_Boekingen.boekstuk = " & fnInQuotes(tabel2!Boekstuk)
DoCmd.SetWarnings False
DoCmd.RunSQL gstr1
DoCmd.SetWarnings True
Next Gint1
tabel3.AddNew
If Gcur1 >= 0 Then tabel3!DC = "D": tabel3!Bedrag = Gcur1
If Gcur1 < 0 Then tabel3!DC = "C": tabel3!Bedrag = Gcur1
tabel3!Omschrijving = "Verdichte boeking"
tabel3!Datum = "31-12-" & jaar
tabel3!RekNr = Tabel1!RekNr
Gcur1 = 0: Gint2 = Gint2 + 1
tabel3.Update
tabel2.Close
Verder:
Tabel1.MoveNext
Loop
Tabel1.Close
If Gint2 > 0 Then
MsgBox "Het aantal gecomprimeerde rekeningen is " & Gint2
End If
End Sub