Controle op feestdagen

  • Onderwerp starter Onderwerp starter RSpan
  • Startdatum Startdatum
Status
Niet open voor verdere reacties.

RSpan

Gebruiker
Lid geworden
10 jun 2009
Berichten
166
Beste forumleden
Onderstaand heb ik een module die de feestdagen van het jaar berekend en d.m.v. een query worden die dan weergegeven in een formulier.
Is het nu mogelijk om van de tabel rooster de ingevoerde datums te vergelijken met de datums die door de module gegenereerd wordt.
Op die manier kan ik het rooster controleren op feestdagen.
In het vorige programma had ik een tabel feestdagen (die handmatig ingevuld moest worden) en dat was makkelijk om middels een query het rooster op feestdagen te controleren.
Met deze module die de feestdagen niet in één veld met verschillende records zet maar in één record met verschillende velden, weet ik niet hoe ik dat moet aanpakken.

Iemand enig idee

Ik hoop het
Groet
René

Code:
Option Compare Database
Option Explicit

Function Pasen(jaar As Integer) As Date
Dim A As Byte
Dim B As Byte
Dim C As Byte
Dim D As Byte
Dim E As Byte

A = jaar Mod 19
B = Int(jaar / 100)
C = Int((3 * B - 5) / 4)
D = (Int(12 + 11 * A + (8 * B + 13) / 25 - C) Mod 30 + 30) Mod 30

If 11 * D < A + 1 Then
    E = 56 - D
Else
    E = 57 - D
End If

Pasen = DateValue("01/03/" & Str(jaar)) + E - 1 - Int(E + (5 * jaar) / 4 - C) Mod 7

End Function

Function IsZZFdag(Datum As Date) As Boolean
Dim jaar As Integer
Dim TDag As String
Dim Pa1 As Date

IsZZFdag = False

'Controleren of de datum een zaterdag of een zondag is
If DatePart("w", Datum) = 1 Or _
   DatePart("w", Datum) = 7 Then
    IsZZFdag = True
    GoTo Einde
End If

'Controleren op feestdagen met een vaste datum
TDag = Format(Datum, "dd-mm")

If TDag = "01-01" Then
    IsZZFdag = True
    GoTo Einde
End If

If TDag = "30-04" Then
    IsZZFdag = True
    GoTo Einde
End If

If TDag = "05-05" Then
    IsZZFdag = True
    GoTo Einde
End If

If TDag = "25-12" Then
    IsZZFdag = True
    GoTo Einde
End If

If TDag = "26-12" Then
    IsZZFdag = True
    GoTo Einde
End If

'Bepalen eerste paasdag
jaar = DatePart("yyyy", Datum)
Pa1 = Pasen(jaar)

'Controle goede vrijdag
If (Datum = Pa1 - 2) Then
    IsZZFdag = True
    GoTo Einde
End If

'Controle tweede paasdag
If (Datum = Pa1 + 1) Then
    IsZZFdag = True
    GoTo Einde
End If

'Controle hemelvaartdag
If (Datum = Pa1 + 39) Then
    IsZZFdag = True
    GoTo Einde
End If

'Controle tweede pinksterdag
If (Datum = Pa1 + 50) Then
    IsZZFdag = True
    GoTo Einde
End If

Einde:
End Function

Query
Code:
SELECT Year(Date()) AS Jaar, pasen([jaar]) AS Pa, Format(DateSerial([Jaar],1,1),"dd-mm-yyyy dddd") AS Nieuwjaar, Format([Pa]-2,"dd-mm-yyyy dddd") AS [Goede vrijdag], Format(([Pa]),"dd-mm-yyyy dddd") AS [1e paasdag], Format(([Pa]+1),"dd-mm-yyyy dddd") AS [2e paasdag], Format(([Pa]+39),"dd-mm-yyyy dddd") AS Hemelvaart, Format(([Pa]+49),"dd-mm-yyyy dddd") AS [1e pinksterdag], Format(([Pa]+50),"dd-mm-yyyy dddd") AS [2e pinksterdag], Format(DateSerial([Jaar],4,30),"dd-mm-yyyy dddd") AS Koninginnedag, Format(DateSerial([Jaar],5,5),"dd-mm-yyyy dddd") AS Bevrijdingsdag, Format(DateSerial([Jaar],12,25),"dd-mm-yyyy dddd") AS [1e kerstdag], Format(DateSerial([Jaar],12,26),"dd-mm-yyyy dddd") AS [2e kerstdag];
 
Laatst bewerkt:
Ik heb er (nog) niet heel erg goed naar gekeken, maar het antwoord op de vraag zelf is niet zo moeilijk. Je kunt met de functie een recordset genereren, die je kunt vergelijken met een tabel. Of, misschien handiger, je kunt een tabel genereren op basis van datums die in een jaar worden aangemaakt.
Overigens zou ik nooit een Datum proberen te maken met Format; je haalt hiermee het DateSerial commando weer onderuit, omdat je datum als Tekst wordt behandeld. Altijd CDate gebruiken!
 
Ik heb er (nog) niet heel erg goed naar gekeken, maar het antwoord op de vraag zelf is niet zo moeilijk. Je kunt met de functie een recordset genereren, die je kunt vergelijken met een tabel. Of, misschien handiger, je kunt een tabel genereren op basis van datums die in een jaar worden aangemaakt.
Overigens zou ik nooit een Datum proberen te maken met Format; je haalt hiermee het DateSerial commando weer onderuit, omdat je datum als Tekst wordt behandeld. Altijd CDate gebruiken!

Dat idee had ik ook maar ik weet niet goed hoe ik de tabel moet genereren opdat ik in de tabel 10 records krijg met één datum veld i.p.v. één record met 10 datum velden waarin de datum van de feestdag(en) staat.
Als dat gebeurt en dat doet de query nu, dan weet ik niet hoe ik hiermee een andere tabel kan controleren op feestdagen aangezien voor elke feestdag een ander veld gebruikt wordt en in de te controleren tabel er maar één veld met datums is.:confused:
 
Je kunt het op deze manier doen:

Code:
Private Sub cmdFeestdagen_Click()
Dim iStart As Integer, iEind As Integer
    iStart = InputBox("Typ het beginjaar", "Beginjaar", Year(Date))
    iEind = InputBox("Typ het eindjaar", "Eindjaar", iStart + 5)
    Call Feestdagen(iStart, iEind)

End Sub

Code:
Private Function Feestdagen(Optional StartJaar As Integer, Optional EindJaar As Integer)
Dim i As Integer
Dim dtPasen As Date
Dim iPasen As Double

If Nz(StartJaar, "") = "" Then StartJaar = Year(Date)
If Nz(EindJaar, "") = "" Then EindJaar = StartJaar

For i = StartJaar To EindJaar
    With CurrentDb.OpenRecordset("SELECT Jaar FROM tFeestdagen WHERE Jaar=" & i)
        If .RecordCount = 0 Then
            'eerst maar eens de Paasdatum berekenen...
            dtPasen = Pasen(i)
            iPasen = CDbl(dtPasen)
            strSQL = "INSERT INTO tFeestdagen " _
            & "( Jaar, Nieuwjaar, [Goede Vrijdag], [1e Paasdag], [2e Paasdag], Hemelvaart, [1e Pinksterdag], [2e Pinksterdag], " _
            & "Koninginnedag, Bevrijdingsdag, [1e Kerstdag], [2e Kerstdag] )" & vbCrLf
            strSQL = strSQL & "VALUES (" & i & ", DateSerial(" & i & ",1,1), " _
            & "CDate(" & iPasen - 2 & "), CDate(" & iPasen & "), CDate(" & iPasen + 1 & "), CDate(" & iPasen + 39 & "), " _
            & "CDate(" & iPasen + 49 & "), CDate(" & iPasen + 50 & "), DateSerial(" & i & ",4,30), " _
            & "DateSerial(" & i & ",5,5), DateSerial(" & i & ",12,25) , DateSerial(" & i & ",12,26))"
            DoCmd.RunSQL (strSQL)
        End If
        .Close
    End With
Next i

End Function

Hierbij kun je zelf aangeven voor hoeveel jaar je de feestdagen wilt maken.
 
Ik heb ook nog een (iets ingewikkelder... ) routine, die elke datum apart in een record zet.
Ziet er als volgt uit:

Code:
Private Function Feestdag(Optional StartJaar As Integer, Optional EindJaar As Integer)
Dim strSQL As String, strInvoer As String
Dim i As Integer, x As Integer
Dim sVeld() As String, sWaarde() As Date
Dim dtPasen As Date
Dim iPasen As Double

If Nz(StartJaar, "") = "" Then StartJaar = Year(Date)
If Nz(EindJaar, "") = "" Then EindJaar = StartJaar

    sVeld = Split("Nieuwjaar|Goede Vrijdag|1e Paasdag|2e Paasdag|Hemelvaart|1e Pinksterdag|2e Pinksterdag|" _
        & "Koninginnedag|Bevrijdingsdag|1e Kerstdag|2e Kerstdag", "|")

    ReDim sWaarde(UBound(sVeld))
    For x = StartJaar To EindJaar
        dtPasen = Pasen(x)
        iPasen = CDbl(dtPasen)
        sWaarde(LBound(sVeld)) = CDate(DateSerial(x, 1, 1))
        sWaarde(LBound(sVeld) + 1) = CDate(iPasen - 2)
        sWaarde(LBound(sVeld) + 2) = CDate(iPasen)
        sWaarde(LBound(sVeld) + 3) = CDate(iPasen + 1)
        sWaarde(LBound(sVeld) + 4) = CDate(iPasen + 39)
        sWaarde(LBound(sVeld) + 5) = CDate(iPasen + 49)
        sWaarde(LBound(sVeld) + 6) = CDate(iPasen + 50)
        sWaarde(LBound(sVeld) + 7) = CDate(DateSerial(x, 4, 30))
        sWaarde(LBound(sVeld) + 8) = CDate(DateSerial(x, 5, 5))
        sWaarde(LBound(sVeld) + 9) = CDate(DateSerial(x, 12, 25))
        sWaarde(LBound(sVeld) + 10) = CDate(DateSerial(x, 12, 26))
        For i = LBound(sVeld) To UBound(sVeld)
            strSQL = "SELECT " & sVeld(i) & " FROM tFeestdag WHERE CDbl(" & sVeld(i) & ") = " & CDbl(sWaarde(i))
            On Error Resume Next
            With CurrentDb.OpenRecordset(strSQL)
                If .RecordCount = 0 Then
                    strInvoer = "INSERT INTO tFeestdag (Feestdag, FeestdagDatum) VALUES ('" & sVeld(i) & "', CDate(" & CDbl(sWaarde(i)) & "))"
                    DoCmd.RunSQL (strInvoer)
                End If
                .Close
            End With
        Next i
    Next x

End Function
 
Laatst bewerkt:
Ik heb ook nog een (iets ingewikkelder... ) routine, die elke datum apart in een record zet.
Ziet er als volgt uit:

Code:
Private Function Feestdag(Optional StartJaar As Integer, Optional EindJaar As Integer)
Dim strSQL As String, strInvoer As String
Dim i As Integer, x As Integer
Dim sVeld() As String, sWaarde() As Date
Dim dtPasen As Date
Dim iPasen As Double

If Nz(StartJaar, "") = "" Then StartJaar = Year(Date)
If Nz(EindJaar, "") = "" Then EindJaar = StartJaar

    sVeld = Split("Nieuwjaar|Goede Vrijdag|1e Paasdag|2e Paasdag|Hemelvaart|1e Pinksterdag|2e Pinksterdag|" _
        & "Koninginnedag|Bevrijdingsdag|1e Kerstdag|2e Kerstdag", "|")

    ReDim sWaarde(UBound(sVeld))
    For x = StartJaar To EindJaar
        dtPasen = Pasen(x)
        iPasen = CDbl(dtPasen)
        sWaarde(LBound(sVeld)) = CDate(DateSerial(x, 1, 1))
        sWaarde(LBound(sVeld) + 1) = CDate(iPasen - 2)
        sWaarde(LBound(sVeld) + 2) = CDate(iPasen)
        sWaarde(LBound(sVeld) + 3) = CDate(iPasen + 1)
        sWaarde(LBound(sVeld) + 4) = CDate(iPasen + 39)
        sWaarde(LBound(sVeld) + 5) = CDate(iPasen + 49)
        sWaarde(LBound(sVeld) + 6) = CDate(iPasen + 50)
        sWaarde(LBound(sVeld) + 7) = CDate(DateSerial(x, 4, 30))
        sWaarde(LBound(sVeld) + 8) = CDate(DateSerial(x, 5, 5))
        sWaarde(LBound(sVeld) + 9) = CDate(DateSerial(x, 12, 25))
        sWaarde(LBound(sVeld) + 10) = CDate(DateSerial(x, 12, 26))
        For i = LBound(sVeld) To UBound(sVeld)
            strSQL = "SELECT " & sVeld(i) & " FROM tFeestdag WHERE CDbl(" & sVeld(i) & ") = " & CDbl(sWaarde(i))
            On Error Resume Next
            With CurrentDb.OpenRecordset(strSQL)
                If .RecordCount = 0 Then
                    strInvoer = "INSERT INTO tFeestdag (Feestdag, FeestdagDatum) VALUES ('" & sVeld(i) & "', CDate(" & CDbl(sWaarde(i)) & "))"
                    DoCmd.RunSQL (strInvoer)
                End If
                .Close
            End With
        Next i
    Next x

End Function



Alvast bedankt Marcel:thumb:

Ik ga er mee aan de gang en laat het je nog weten als het gelukt is

mvg:)
René
 
Alvast bedankt Marcel:thumb:

Ik ga er mee aan de gang en laat het je nog weten als het gelukt is

mvg:)
René

Hoi Marcel

Ik heb je hulp toch nog nodig.
Ik heb nu een module feestdagen gemaakt en jouw code er in gezet en een tabel Feestdag gemaakt met de velden feestdag en feestdagdatum.
ik neem aan dat ik nu middels een query deze tabel kan vullen met de feestdagen(datums) van het actuele jaar.
Die query lukt me niet.:o

heb ik nog een vraag, kan ik met deze funtie ook rechtstreeks een tabel met datums (tblRooster) controleren op feestdagen?

Ik hoor graag van je
Groet:)
René
 
De functie(s) wordt aangeroepen met een knop:

Code:
Private Sub cmdFeestdagen_Click()
Dim iStart As Integer, iEind As Integer
    iStart = InputBox("Typ het beginjaar", "Beginjaar", Year(Date))
    iEind = InputBox("Typ het eindjaar", "Eindjaar", iStart + 5)
    Call Feestdag(iStart, iEind)

End Sub

Die kun je uiteraard zelf nog verder verbouwen. De tabel in het voorbeeld (tFeestdag of tFeestdagen) moet wel bestaan, anders kun je geen toevoegquery gebruiken. Dan zou er eerst een tabelmaak routine moeten draaien.
Daarna kun je de functie dus met een knop laten draaien, en wordt de tabel gevuld.
Je krijgt dus geen rechtstreekse query als resultaat. Die kun je op een normale manier maken, waarbij je de datums dan gaat vergelijken met de tabel Feestdagen.
 
De functie(s) wordt aangeroepen met een knop:

Code:
Private Sub cmdFeestdagen_Click()
Dim iStart As Integer, iEind As Integer
    iStart = InputBox("Typ het beginjaar", "Beginjaar", Year(Date))
    iEind = InputBox("Typ het eindjaar", "Eindjaar", iStart + 5)
    Call Feestdag(iStart, iEind)

End Sub

Die kun je uiteraard zelf nog verder verbouwen. De tabel in het voorbeeld (tFeestdag of tFeestdagen) moet wel bestaan, anders kun je geen toevoegquery gebruiken. Dan zou er eerst een tabelmaak routine moeten draaien.
Daarna kun je de functie dus met een knop laten draaien, en wordt de tabel gevuld.
Je krijgt dus geen rechtstreekse query als resultaat. Die kun je op een normale manier maken, waarbij je de datums dan gaat vergelijken met de tabel Feestdagen.

Ok duidelijk ga verder met sleutelen
 
De functie(s) wordt aangeroepen met een knop:

Code:
Private Sub cmdFeestdagen_Click()
Dim iStart As Integer, iEind As Integer
    iStart = InputBox("Typ het beginjaar", "Beginjaar", Year(Date))
    iEind = InputBox("Typ het eindjaar", "Eindjaar", iStart + 5)
    Call Feestdag(iStart, iEind)

End Sub

Die kun je uiteraard zelf nog verder verbouwen. De tabel in het voorbeeld (tFeestdag of tFeestdagen) moet wel bestaan, anders kun je geen toevoegquery gebruiken. Dan zou er eerst een tabelmaak routine moeten draaien.
Daarna kun je de functie dus met een knop laten draaien, en wordt de tabel gevuld.
Je krijgt dus geen rechtstreekse query als resultaat. Die kun je op een normale manier maken, waarbij je de datums dan gaat vergelijken met de tabel Feestdagen.



Hoi Marcel

ik heb de code onder een knop gebracht en vervolgens deze getest.
Bij de dbase compileren krijg ik een foutmelding t.w. " compileerfout: sub of function is niet gedefinieerd "
en de regel "Call Feestdag" staat dan geselecteerd.

Enig idee wat er fout gaat?

nog even voor de duidelijkheid
deze code heb ik onder de knop cmdFeestdagen gezet
Code:
Private Sub cmdFeestdagen_Click()
Dim iStart As Integer, iEind As Integer
    iStart = InputBox("Typ het beginjaar", "Beginjaar", Year(Date))
    iEind = InputBox("Typ het eindjaar", "Eindjaar", iStart + 5)
    Call Feestdag(iStart, iEind)

End Sub

waarbij ik me afvraag of de inputBox nodig is er wordt nl toch niets ingevoerd, maar van het huidige jaar uit gegaan.

en in de module heb ik deze code gezet:
Code:
Private Function Feestdag(Optional StartJaar As Integer, Optional EindJaar As Integer)
Dim strSQL As String, strInvoer As String
Dim i As Integer, x As Integer
Dim sVeld() As String, sWaarde() As Date
Dim dtPasen As Date
Dim iPasen As Double

If Nz(StartJaar, "") = "" Then StartJaar = Year(Date)
If Nz(EindJaar, "") = "" Then EindJaar = StartJaar

    sVeld = Split("Nieuwjaar|Goede Vrijdag|1e Paasdag|2e Paasdag|Hemelvaart|1e Pinksterdag|2e Pinksterdag|" _
        & "Koninginnedag|Bevrijdingsdag|1e Kerstdag|2e Kerstdag", "|")

    ReDim sWaarde(UBound(sVeld))
    For x = StartJaar To EindJaar
        dtPasen = Pasen(x)
        iPasen = CDbl(dtPasen)
        sWaarde(LBound(sVeld)) = CDate(DateSerial(x, 1, 1))
        sWaarde(LBound(sVeld) + 1) = CDate(iPasen - 2)
        sWaarde(LBound(sVeld) + 2) = CDate(iPasen)
        sWaarde(LBound(sVeld) + 3) = CDate(iPasen + 1)
        sWaarde(LBound(sVeld) + 4) = CDate(iPasen + 39)
        sWaarde(LBound(sVeld) + 5) = CDate(iPasen + 49)
        sWaarde(LBound(sVeld) + 6) = CDate(iPasen + 50)
        sWaarde(LBound(sVeld) + 7) = CDate(DateSerial(x, 4, 30))
        sWaarde(LBound(sVeld) + 8) = CDate(DateSerial(x, 5, 5))
        sWaarde(LBound(sVeld) + 9) = CDate(DateSerial(x, 12, 25))
        sWaarde(LBound(sVeld) + 10) = CDate(DateSerial(x, 12, 26))
        For i = LBound(sVeld) To UBound(sVeld)
            strSQL = "SELECT " & sVeld(i) & " FROM TblFeestdag WHERE CDbl(" & sVeld(i) & ") = " & CDbl(sWaarde(i))
            On Error Resume Next
            With CurrentDb.OpenRecordset(strSQL)
                If .RecordCount = 0 Then
                    strInvoer = "INSERT INTO TblFeestdag (Feestdag, FeestdagDatum) VALUES ('" & sVeld(i) & "', CDate(" & CDbl(sWaarde(i)) & "))"
                    DoCmd.RunSQL (strInvoer)
                End If
                .Close
            End With
        Next i
    Next x

End Function
 
Laatst bewerkt:
De functie(s) wordt aangeroepen met een knop:

Code:
Private Sub cmdFeestdagen_Click()
Dim iStart As Integer, iEind As Integer
    iStart = InputBox("Typ het beginjaar", "Beginjaar", Year(Date))
    iEind = InputBox("Typ het eindjaar", "Eindjaar", iStart + 5)
    Call Feestdag(iStart, iEind)

End Sub

Die kun je uiteraard zelf nog verder verbouwen. De tabel in het voorbeeld (tFeestdag of tFeestdagen) moet wel bestaan, anders kun je geen toevoegquery gebruiken. Dan zou er eerst een tabelmaak routine moeten draaien.
Daarna kun je de functie dus met een knop laten draaien, en wordt de tabel gevuld.
Je krijgt dus geen rechtstreekse query als resultaat. Die kun je op een normale manier maken, waarbij je de datums dan gaat vergelijken met de tabel Feestdagen.

Hoi, hoi

ik ben er uit.
Ik heb Private uit de functie verwijderd en nu werkt het:D
Ik ga nu de controle funtie maken.
Bedankt weer voor de hulp Michel:thumb::thumb:

Groet
René
 
Laatst bewerkt:
Nu je m'n naam weer weet :thumb: zal ik er nog een foutje uithalen...
Je moet deze regel:

Code:
            strSQL = "SELECT " & sVeld(i) & " FROM tFeestdag WHERE CDbl(" & sVeld(i) & ") = " & CDbl(sWaarde(i))
vervangen door:
Code:
            strSQL = "SELECT FeestdagDatum FROM tFeestdag WHERE FeestdagDatum = cDate(" & CDbl(sWaarde(i)) & ")"

De check op reeds ingevoerde datums was derhalve niet correct... de oorspronkelijke code was meer bedoeld om te kijken of de veldnaamgegevens wel goed werden ingevuld.
De nieuwe variant controleert de in te voeren waarde, en doet dat vervolgens alleen als de recordcount 0 is, derhalve nog niet bestaat...
 
Nu je m'n naam weer weet :thumb: zal ik er nog een foutje uithalen...
Je moet deze regel:

Code:
            strSQL = "SELECT " & sVeld(i) & " FROM tFeestdag WHERE CDbl(" & sVeld(i) & ") = " & CDbl(sWaarde(i))
vervangen door:
Code:
            strSQL = "SELECT FeestdagDatum FROM tFeestdag WHERE FeestdagDatum = cDate(" & CDbl(sWaarde(i)) & ")"

De check op reeds ingevoerde datums was derhalve niet correct... de oorspronkelijke code was meer bedoeld om te kijken of de veldnaamgegevens wel goed werden ingevuld.
De nieuwe variant controleert de in te voeren waarde, en doet dat vervolgens alleen als de recordcount 0 is, derhalve nog niet bestaat...

Ok, bedankt Michel,:thumb: ik heb het veranderd.
 
Status
Niet open voor verdere reacties.

Nieuwste berichten

Terug
Bovenaan Onderaan