Zum Inhalt dieser Seite

Access - 'Feiertage'

Weiter unten kommen die Anweisungen für das Datumsfeld im Formular, ein Download einer Demo-Datenbank ist durch Klick auf den folgenden Link möglich: (55 kByte) . Falls noch mehr Feiertage kontrolliert werden sollen, so muss das globale Array 'FeierArray' größer dimensioniert werden. Im Augenblick können maximal 16 Feiertage (Index 0 bis 15) eingetragen werden. Außerdem müssen alle Anweisungen, in denen das Array durchlaufen wird (im Augenblick von 0 bis 15), angepasst werden.

Mit folgendem Code (in ein Modul kopieren) kann überprüft werden, ob es sich bei einem Eingabewert in einem Formular um einen Arbeitstag handelt): 

Option Compare Database
Option Explicit
'Public Const Arbeitstage = 0 'Feiertage etc. nicht beachten
'Public Const Arbeitstage = 1 'nur Samstag und Sonntag
'Public Const Arbeitstage = 2 'Samstag, Sonntag und
                              'bundesweite Feiertage (ohne regionale)
Public Arbeitstage As Integer
Public FeierArray(15, 2) As Variant
 
 
 
Public Function Feiertage(Optional xJahr As Long)
 
On Error GoTo FeierTage_Err:
 
Dim m As Integer
Dim n As Integer
Dim a As Integer
Dim B As Integer
Dim c As Integer
Dim d As Integer
Dim e As Integer
Dim Tag As Integer
Dim Mon As Integer
Dim TagDerWoche As Integer 'xter Tag der Woche
                           '(Montag = 1, Dienstag = 2 usw.)
Dim FTagName As String
Dim strJahr As String
Dim Datum As Date
Dim ArrayEint As Byte
Dim Fehlermeldung As Integer
Dim datOsterSonntag As Date
 
If IsMissing(xJahr) Then
  strJahr = Format$(Year(Date))
 Else
  strJahr = Format$(xJahr)
End If
 
'bewegliche Feiertage
'Ostersonntag
m = 23
n = 3
 
If xJahr > 1799 Then
  n = 4
End If
 
If xJahr > 1899 Then
  n = n + 1
  m = 24
End If
 
If xJahr > 2099 Then
  n = n + 1
End If
 
a = xJahr Mod 19
B = xJahr Mod 4
c = xJahr Mod 7
d = ((a * 19) + m) Mod 30
e = ((B * 2) + (c * 4) + (d * 6) + n) Mod 7
Tag = d + e + 22
 
If Tag > 31 Then
  Tag = Tag - 31
  If (Tag = 26) Or ((Tag = 25) And (d = 28) And (a > 10)) Then
    Tag = Tag - 7
  End If
  Mon = 4
 Else
  Mon = 3
End If
 
Datum = CDate(Format$(Tag) & "." & Format$(Mon) & ". " & strJahr)
datOsterSonntag = Datum
FTagName = "Ostersonntag"
ArrayEint = EintragFeiertag(3, Datum, FTagName, True)
 
'Karfreitag
Datum = datOsterSonntag - 2
FTagName = "Karfreitag"
ArrayEint = EintragFeiertag(2, Datum, FTagName, True)
 
'Ostermontag
Datum = datOsterSonntag + 1
FTagName = "Ostermontag"
ArrayEint = EintragFeiertag(4, Datum, FTagName, True)
 
'Pfingstsonntag
Datum = datOsterSonntag + 49
FTagName = "Pfingstsonntag"
ArrayEint = EintragFeiertag(7, Datum, FTagName, True)
 
'Pfingstmontag
Datum = datOsterSonntag + 50
FTagName = "Pfingstmontag"
ArrayEint = EintragFeiertag(8, Datum, FTagName, True)
 
'Chr.Himmelfahrt
Datum = datOsterSonntag + 39
FTagName = "Christi Himmelfahrt"
ArrayEint = EintragFeiertag(6, Datum, FTagName, True)
 
'Frohnleichnam
Datum = datOsterSonntag + 60
FTagName = "Frohnleichnam"
ArrayEint = EintragFeiertag(9, Datum, FTagName, False)
 
'Buß+Bettag
Datum = CDate("1.11." & strJahr)
Do
  TagDerWoche = CInt(Format$(Datum, "w", vbMonday))
  Select Case TagDerWoche
   Case 3              'Mittwoch
    Datum = Datum + 14
   Case Else           'anderer Wochentag (nicht Mittwoch)
    Datum = Datum + 1
  End Select
Loop While TagDerWoche <> 3
If Day(Datum) < 16 Then
  Datum = Datum + 7
End If
FTagName = "Buß und Bettag"
ArrayEint = EintragFeiertag(13, Datum, FTagName, False)
 
'feste Feiertage
Datum = CDate("1.1." & strJahr)
FTagName = "Neujahr"
ArrayEint = EintragFeiertag(0, Datum, FTagName, True)
 
Datum = CDate("6.1." & strJahr)
FTagName = "Heilige drei Könige"
ArrayEint = EintragFeiertag(1, Datum, FTagName, False)
 
Datum = CDate("1.5." & strJahr)
FTagName = "Tag der Arbeit"
ArrayEint = EintragFeiertag(5, Datum, FTagName, True)
 
Datum = CDate("3.10." & strJahr)
FTagName = "Tag der deutschen Einheit"
ArrayEint = EintragFeiertag(11, Datum, FTagName, True)
 
Datum = CDate("15.8." & strJahr)
FTagName = "Mariä Himmelfahrt"
ArrayEint = EintragFeiertag(10, Datum, FTagName, False)
 
Datum = CDate("1.11." & strJahr)
FTagName = "Allerheiligen"
ArrayEint = EintragFeiertag(12, Datum, FTagName, False)
 
Datum = CDate("25.12." & strJahr)
FTagName = "1. Weihnachtstag"
ArrayEint = EintragFeiertag(14, Datum, FTagName, True)
 
Datum = CDate("26.12." & strJahr)
FTagName = "2. Weihnachtstag"
ArrayEint = EintragFeiertag(15, Datum, FTagName, True)
 
'nur für Debug-Zwecke
'zeige = ZTage()
 
Feiertage_Exit:
  Exit Function
 
FeierTage_Err:
  If Err.Number = 13 Then
    Fehlermeldung = MsgBox("Die eingegebene Jahreszahl '" & CStr(xJahr) _
                    & "' ist zu gross. Gültige Jahreswerte " _
                    & "bewegen sich zwischen '0' und '9999'", _
                    vbExclamation, "Fehler in der Funktion 'Feiertage'")
   Else
    MsgBox Err.Description
  End If
  Resume Feiertage_Exit:
 
End Function
 
 
 
Public Function EintragFeiertag(iArray, WDatum, TName, Bundesweit) As Byte
 
FeierArray(iArray, 0) = WDatum
FeierArray(iArray, 1) = TName
FeierArray(iArray, 2) = Bundesweit
 
End Function
 
 
 
Public Function ZTage()
 
'nur für Debug-Zwecke
'kann im Direktfenster mit ?ZTage() aufgerufen werden,
'nachdem Feiertage mit ?Feiertage() eingelesen wurden.
 
Dim i As Byte
Dim LEintrag As Integer
 
For i = 0 To 15
  LEintrag = Len(FeierArray(i, 1))
  'Debug.Print FeierArray(i, 0) & "  " & FeierArray(i, 1) _
               & Space(27 - LEintrag) & FeierArray(i, 2)
  ZTage = ZTage & FeierArray(i, 0) & "  " & FeierArray(i, 1) _
          & Space(27 - LEintrag) & FeierArray(i, 2) & Chr(13) & Chr(10)
Next i
 
End Function
 
 
 
Public Function IstArbeitstag(WDatum As Date)
 
Dim Meldetext1 As String, Meldetext2 As String
Dim Welchertag As String, Trenner As String
Dim RGabe As String, Zusatz As String
Dim ITemp As Boolean
Dim DJahr As Long, AJahr As Long
Dim i As Byte
Dim ArrayNeu, ArrayDatum, ArrayBeschr, ArrayBWeit
 
Welchertag = GibWotag(WDatum)
Meldetext1 = "Bei dem eingegebenen Datum '"
Meldetext2 = "' handelt es sich um einen"
Trenner = Chr(13) & Chr(10)
ITemp = True
 
Select Case Arbeitstage
 
 Case Is = 0         'Feiertage etc. nicht beachten
  RGabe = ITemp
 
 Case Is = 1         'nur Samstag und Sonntag
  If Welchertag = "Samstag" Or Welchertag = "Sonntag" Then
    ITemp = False
    RGabe = Meldetext1 & WDatum & Meldetext2 & Trenner & Welchertag & "."
   Else
    RGabe = ITemp
  End If
 
 Case Is = 2         'Samstag,Sonntag und nur bundesweite Feiertage
  RGabe = ITemp
  DJahr = CLng(Year(WDatum))
  If Not IsNull(FeierArray(0, 0)) Then
    AJahr = Year(CVDate(FeierArray(0, 0)))
   Else
    AJahr = Null
  End If
  If DJahr <> AJahr Then
    ArrayNeu = Feiertage(CLng(Year(WDatum)))
  End If
  For i = 0 To 15
    ArrayDatum = CVDate(FeierArray(i, 0))
    ArrayBeschr = FeierArray(i, 1)
    ArrayBWeit = FeierArray(i, 2)
    If ArrayDatum = WDatum And ArrayBWeit = True Then
      ITemp = False
      RGabe = Meldetext1 & CStr(WDatum) & Meldetext2 & Trenner _
              & "bundesweiten Feiertag (" & ArrayBeschr & ")."
      i = 15
    End If
  Next i
  If ITemp = True And (Welchertag = "Samstag" _
  Or Welchertag = "Sonntag") Then
    ITemp = False
    RGabe = Meldetext1 & CStr(WDatum) & Meldetext2 _
            & Trenner & Welchertag & "."
   Else
    RGabe = RGabe
  End If
 
 Case Is = 3         'Samstag,Sonntag und alle Feiertage
  RGabe = ITemp
  DJahr = CLng(Year(WDatum))
  If Not IsNull(FeierArray(0, 0)) Then
    AJahr = Year(CVDate(FeierArray(0, 0)))
   Else
    AJahr = Null
  End If
  If DJahr <> AJahr Then
    ArrayNeu = Feiertage(CLng(Year(WDatum)))
  End If
  For i = 0 To 15
    ArrayDatum = CVDate(FeierArray(i, 0))
    ArrayBeschr = FeierArray(i, 1)
    ArrayBWeit = FeierArray(i, 2)
    If ArrayDatum = WDatum Then
      ITemp = False
      If ArrayBWeit = True Then
        Zusatz = "bundesweiten"
       Else
        Zusatz = "regionalen"
      End If
      RGabe = Meldetext1 & CStr(WDatum) & Meldetext2 & Trenner _
              & Zusatz & " Feiertag (" & ArrayBeschr & ")."
      i = 15
    End If
  Next i
  If ITemp = True And (Welchertag = "Samstag" Or Welchertag = "Sonntag") Then
    ITemp = False
    RGabe = Meldetext1 & CStr(WDatum) & Meldetext2 _
            & Trenner & Welchertag & "."
   Else
    RGabe = RGabe
  End If
 
End Select
 
IstArbeitstag = RGabe
 
End Function
 
 
 
Public Function GibWotag(WDatum As Date)
 
Dim DayofWeek As Byte
Dim GTemp As String
 
DayofWeek = Weekday(WDatum)
 
Select Case DayofWeek
 Case 1
  GTemp = "Sonntag"
 Case 2
  GTemp = "Montag"
 Case 3
  GTemp = "Dienstag"
 Case 4
  GTemp = "Mittwoch"
 Case 5
  GTemp = "Donnerstag"
 Case 6
  GTemp = "Freitag"
 Case 7
  GTemp = "Samstag"
End Select
 
GibWotag = GTemp
 
End Function
 
 
 
Public Function Kontrolle(KDAtum As Date, _
                          QuietMode As Boolean, Richtung As Integer)
 
Dim LDat As Date
Dim Neudat As Date
Dim ZWert As Date
Dim MeldeDat As String, tDat As String, Zusatz As String
Dim Antwort As Integer
Dim i As Byte
 
LDat = KDAtum
 
MeldeDat = IstArbeitstag(LDat)
 
If Left(MeldeDat, 3) = "Bei" Then
  For i = 0 To 7
    tDat = IstArbeitstag(LDat)
    If Left(tDat, 3) <> "Bei" Then
      Neudat = LDat
      If Richtung = 1 Then
        i = 7
       Else
        If LDat < KDAtum Then
         Neudat = LDat
         i = 7
        End If
      End If
    End If
    LDat = LDat + 1 * Richtung
  Next i
  If Richtung = 1 Then
    Zusatz = "nächsten"
   Else
    Zusatz = "vorigen"
  End If
  If QuietMode = True Then
    Antwort = vbYes
   Else
    Antwort = MsgBox(MeldeDat & Chr(13) & Chr(10) _
              & "Soll das Datum auf den " & Zusatz & " Arbeitstag (" _
              & Neudat & ") gestellt werden ?", vbYesNo + vbInformation, _
              "Datumskontrolle (handelt es sich um einen Werktag ?)")
  End If
  If Antwort = vbYes Then
    ZWert = Neudat
   Else
    ZWert = KDAtum
  End If
End If
 
If Left(CStr(ZWert), 2) = "00" Then
  ZWert = KDAtum
End If
 
Kontrolle = ZWert
 
End Function

Anweisungen für das Formular (in das Modul des Formulars kopieren) :
(zu kontrollierendes Feld heisst im Formular 'Datumsfeld') 

Option Compare Database
Option Explicit
Dim k As Date
 
 
 
Private Sub Datumsfeld_AfterUpdate()
 
'für -Datumsfeld- muss der tatsächliche Name des Feldes im
'Formular eingesetzt werden.
'die untenstehende Anweisung kontrolliert, ob es sich bei dem
'eingegebenen Datum (Parameter 1) um einen Werktag handelt.
'Wenn nicht, wird nachgefragt (Parameter 2), ob der nächstfolgende
'Arbeitstag eingesetzt werden soll (Parameter 3).
 
k = Kontrolle(Me!Datumsfeld, False, 1)
'Ohne Nachfrage müsste das so aussehen:
'k = Kontrolle(Me!Datumsfeld, True, 1)
Me!Datumsfeld = k
 
End Sub