VBA Code
27.01.2005 18:58:04
Heinz
Hab einen VBA Code bekommen und möchte ihn ausprobieren, wenn ich aber auf "Ausführen und "Kompilieren" gehe kommt die Meldung "Fehler beim Kompilieren Syntaxfehler"
Attribute VB_Name = "modHolidays"
Option Explicit
' *** Den Artikel zu diesem Modul finden Sie unter http://www.aboutvb.de/khw/artikel/khwholidays.htm ***
Public Enum HolidayConstants
KeineFeiertage = 0
Neujahr = 1
HlDreiKoenige = 2
Rosenmontag = 4
Karfreitag = 8
OsterSo = 16
OsterMo = 32
ErsterMai = 64
Himmelfahrt = 128
PfingstSo = 256
PfingstMo = 512
Fronleichnam = 1024
Bundesfeier = 2048
AugsburgFrieden = 4096
MariaHimmel = 8192
DeutscheEinheit = 16384
Nationalfeier = 32768
Reformationstag = 65536
Allerheiligen = 131072
BussUndBet = 262144
MariaEmpf = 524288
Weihnacht1 = 1048576
Weihnacht2 = 2097152
End Enum
Public Const HdErrInvalidHoliday = 5
Public Const HdErrInvalidYear = 6
Public
Function EasterSunday(ByVal TestYear As Integer) As Date
Dim nN As Long
Dim nM As Long
Dim nA As Long
Dim nB As Long
Dim nC As Long
Dim nD As Long
Dim nE As Long
Dim nDate As Date
Select Case TestYear
Case 1582 To 1699
nM = 22
nN = 2
Case 1700 To 1799
nM = 23
nN = 3
Case 1800 To 1899
nM = 23
nN = 4
Case 1900 To 2099
nM = 24
nN = 5
Case 2100 To 2199
nM = 24
nN = 6
Case 2200 To 2299
nM = 25
nN = 0
Case 2300 To 2399
nM = 26
nN = 1
Case 2400 To 2499
nM = 25
nN = 1
Case Else
Err.Raise HdErrInvalidYear
End Select
nA = TestYear Mod 19
nB = TestYear Mod 4
nC = TestYear Mod 7
nD = ((19 * nA) + nM) Mod 30
nE = ((2 * nB) + (4 * nC) + (6 * nD) + nN) Mod 7
If (22 + nD + nE) > 31 Then
nDate = DateSerial(TestYear, 4, (nD + nE - 9))
Else
nDate = DateSerial(TestYear, 3, (22 + nD + nE))
End If
If Day(nDate) = 26 And Month(nDate) = 4 Then
nDate = DateSerial(TestYear, 4, 19)
End If
If Day(nDate) = 25 And Month(nDate) = 4 Then
If (nD = 28 And nA > 10) Then
nDate = DateSerial(TestYear, 4, 18)
End If
End If
EasterSunday = nDate
End Function
Public
Function Holiday(ByVal TestYear As Integer, ByVal Holidays As HolidayConstants) As Date
Dim nEasterDate As Date
Dim nDaysNovember As Integer
Select Case TestYear
Case 1582 To 2499
Case Else
Err.Raise HdErrInvalidYear
End Select
nEasterDate = EasterSunday(TestYear)
Select Case Holidays
Case Neujahr
Holiday = DateSerial(TestYear, 1, 1)
Case HlDreiKoenige
Holiday = DateSerial(TestYear, 1, 6)
Case Rosenmontag
Holiday = DateAdd("d", -48, nEasterDate)
Case Karfreitag
Holiday = DateAdd("d", -2, nEasterDate)
Case OsterSo
Holiday = nEasterDate
Case OsterMo
Holiday = DateAdd("d", 1, nEasterDate)
Case ErsterMai
Holiday = DateSerial(TestYear, 5, 1)
Case Himmelfahrt
Holiday = DateAdd("d", 39, nEasterDate)
Case PfingstSo
Holiday = DateAdd("d", 49, nEasterDate)
Case PfingstMo
Holiday = DateAdd("d", 50, nEasterDate)
Case Fronleichnam
Holiday = DateAdd("d", 60, nEasterDate)
Case Bundesfeier
Holiday = DateSerial(TestYear, 8, 1)
Case AugsburgFrieden
Holiday = DateSerial(TestYear, 8, 8)
Case MariaHimmel
Holiday = DateSerial(TestYear, 8, 15)
Case DeutscheEinheit
Select Case TestYear
Case 1954 To 1989
Holiday = DateSerial(TestYear, 6, 17)
Case Is > 1989
Holiday = DateSerial(TestYear, 10, 3)
Case Else
Err.Raise HdErrInvalidYear
End Select
Case Nationalfeier
Holiday = DateSerial(TestYear, 10, 26)
Case Reformationstag
Holiday = DateSerial(TestYear, 12, 31)
Case Allerheiligen
Holiday = DateSerial(TestYear, 11, 1)
Case BussUndBet
For nDaysNovember = 1 To 7
nEasterDate = DateSerial(TestYear, 11, nDaysNovember)
If Weekday(nEasterDate) = 4 Then
Holiday = DateAdd("d", 14, nEasterDate)
Exit Function
End If
Next nDaysNovember
Case MariaEmpf
Holiday = DateSerial(TestYear, 12, 6)
Case Weihnacht1
Holiday = DateSerial(TestYear, 12, 25)
Case Weihnacht2
Holiday = DateSerial(TestYear, 12, 26)
Case Else
Err.Raise HdErrInvalidHoliday
End Select
End Function
Public
Function IsHoliday(ByVal TestDate As Date, ByVal Holidays As HolidayConstants) As Boolean
Dim nTestHoliday As Long
Dim nTest As Long
TestDate = CLng(CDbl(TestDate))
Select Case Year(TestDate)
Case 1582 To 2499
Case Else
Err.Raise HdErrInvalidYear
End Select
For nTestHoliday = 1 To 21
nTest = 2 ^ nTestHoliday
If (Holidays And nTest) = nTest Then
If Holiday(Year(TestDate), nTest) = TestDate Then
IsHoliday = True
Exit Function
End If
End If
Next 'nTestHoliday
End Function
Public
Function HolidaysOfYear(ByVal TestYear As Integer, ByVal Holidays As HolidayConstants) As Collection
Dim nTestHoliday As Long
Dim nTest As Long
Select Case TestYear
Case 1582 To 2499
Case Else
Err.Raise HdErrInvalidYear
End Select
Set HolidaysOfYear = New Collection
With HolidaysOfYear
For nTestHoliday = 1 To 21
nTest = 2 ^ nTestHoliday
If (Holidays And nTest) = nTest Then
HolidaysOfYear.Add Holiday(TestYear, nTest), CStr(nTestHoliday)
End If
Next 'nTestHoliday
End With
End Function