Follow along with the video below to see how to install our site as a web app on your home screen.
Note: This feature may not be available in some browsers.
Function IstFeiertag( _
Optional ByVal Datum As Variant _
) As Boolean
IstFeiertag = Len(Feiertag(Datum)) > 0
End Function
Function Holiday()
DoEvents
Dim Dba As DAO.Database, Rst As DAO.Recordset
Set Dba = CurrentDb
Dim Jahr As Integer
Dim Datum As Variant
' Jahr = Year(Now)
Jahr = 2003
'Debug.Print "Feiertage im Jahr"; Jahr
For Datum = DateSerial(Jahr, 1, 1) To DateSerial(Jahr, 12, 31)
Set Rst = Dba.OpenRecordset("SELECT * FROM tbl_Wochentag" _
& " WHERE cdate([Datum]) = '" _
& Datum & "'")
If IstFeiertag(Datum) Then 'Debug.Print Datum, Feiertag(Datum)
Rst.Edit
Rst("ft") = -1
Rst.Update
End If
Next Datum
End Function
Public Function Feiertag( _
Optional ByVal Datum As Variant _
) As String
Dim TagMonat As Integer
If IsMissing(Datum) Then Datum = Now
TagMonat = Day(Datum) * 100 + Month(Datum)
Select Case TagMonat 'im Format DDMM
Case 101: Feiertag = "Neujahr"
'Case 601: Feiertag = "Dreikönigstag *"
Case 105: Feiertag = "Tag der Arbeit"
'Case 1508: Feiertag = "Mariä Himmelfahrt *"
Case 310: Feiertag = "Tag der deutschen Einheit"
Case 111: Feiertag = "Allerheiligen"
'Case 2412: Feiertag = "Heiligabend *"
Case 2512: Feiertag = "1. Weihnachtstag"
Case 2612: Feiertag = "2. Weihnachtstag"
'Case 3112: Feiertag = "Silvester *"
Case Else: Feiertag = FeiertagV(Datum)
End Select
End Function
Public Function FeiertagV( _
Optional ByVal Datum As Variant _
) As String
Dim Tage As Integer
If IsMissing(Datum) Then Datum = Now
Tage = DateDiff("d", Ostersonntag(Year(Datum)), Datum)
Select Case Tage 'relativ zu Ostersonntag
Case -2: FeiertagV = "Karfreitag"
Case 0: FeiertagV = "Ostersonntag"
Case 1: FeiertagV = "Ostermontag"
Case 39: FeiertagV = "Christi Himmelfahrt"
Case 49: FeiertagV = "Pfingsonntag"
Case 50: FeiertagV = "Pfingstmontag"
Case 60: FeiertagV = "Fronleichnam"
End Select
End Function
Public Function Ostersonntag( _
Optional ByVal Jahr As Integer _
) As Variant
Dim d1 As Integer
Dim d2 As Integer
Dim d3 As Integer
Dim d4 As Integer
'Formel nach C.F.Gauss gilt 1583 - 8202:
If Jahr = 0 Then Jahr = Year(Now)
If Jahr < 1583 Or Jahr > 8202 Then _
Err.Raise 5 'Invalid argument'
'Berechnung der Korrekturwerte:
d1 = (8 * (Jahr \ 100) + 13) \ 25 - 2
d2 = (Jahr \ 100) - (Jahr \ 400) - 2
d1 = (15 + d2 - d1) Mod 30
d3 = 2 * (Jahr Mod 4) + 4 * (Jahr Mod 7)
d4 = (d1 + 19 * (Jahr Mod 19)) Mod 30
If d4 = 29 Then
d4 = 28
ElseIf d4 = 28 Then
If (Jahr Mod 19) > 10 Then d4 = 27
End If
d3 = (6 + d2 + d3 + 6 * d4) Mod 7
'Berechnung des Datums (ausgehend vom 22.3.):
Ostersonntag = DateSerial(Jahr, 3, 22 + d4 + d3)
End Function