Option Compare Database

    'zunächst auf Modulebene im Klassenmodul definiert,
        'und zwar als dynamisches Array des Typs FTag
Dim arrFTage() As FTag
Dim typFTag As FTag

    'Da öffentliche Datentypen in Klassenmodulen nicht zulässig sind,
        'müssen Sie hier zwingend das Schlüsselwort Private verwenden
Private Type FTag
    Tag As Byte
    Monat As Byte
    Name As String
    Land As String
End Type

'Klassenmodul ein und setzen dessen Name Eigenschaft auf clsFeiertage
    'Innerhalb der Klasse erstellen Sie eine öffentliche Funktion
    'Ostersonntag(), der Sie als Parameter die Jahreszahl übergeben
    'Damit ist schon die erste Variable der Formel bekannt.
Public Function Ostersonntag(lngJahr As Long) As Variant

Dim strFehler As String
Dim lngTag As Long
Dim bytMonat As Byte
Dim bytA As Byte
Dim bytB As Byte
Dim bytM As Byte
Dim bytN As Byte
Dim lngE As Long
Dim lngD As Long

    'Berechnen von A, B und C
bytA = lngJahr Mod 19
bytB = lngJahr Mod 4
bytC = lngJahr Mod 7
    'Ermitteln von M und N
bytM = 0
bytN = 0
    'gemäß der "Tabelle" in getMundN berechnet und zurückgibt
strFehler = getMundN(bytM, bytN, lngJahr)

If strFehler = "" Then
        'Berechnung fortsetzen
        'Berechnen von D
    lngD = ((19 * bytA) + bytM) Mod 30
    lngE = ((2 * bytB) + (4 * bytC) + (6 * lngD) + bytN) Mod 7
        'Tag berechnen
    lngTag = 22 + lngD + lngE
        'Ausnahmen prüfen
        'Ist Ostersonntag größer als 31, fällt Ostern in den April.
        'Der Tag wird dann wie folgt berechnet: Ostersonntag =D+E-9.
    If lngTag > 31 Then
        bytMonat = 4
        lngTag = lngD + lngE - 9
        
            'weitere Ausnahmen prüfen
        If lngTag = 26 Then
                'Ist Ostersonntag der 26. April fällt Ostern
                'auf den 19. April
            lngTag = 19
        ElseIf lngTag = 25 Then
                'Ist Ostersonntag der 25. April und gleichzeitig
                'A > 10 und D = 28, dann ist Ostersonntag der 18. April
            If (bytA > 10) And (bytB = 28) Then
                lngTag = 18
            End If
        End If
        
    Else
    
        bytMonat = 3
    End If
End If

    'Gültigkeitsprüfung durchführen
    'Prüfen, ob das Datum gültig ist.
If (bytMonat > 0) And (lngTag > 0) Then

    Ostersonntag = DateSerial(lngJahr, bytMonat, lngTag)
    
        'prüfen, ob das berechnete Datum ein Sonntag ist.
    If Weekday(Ostersonntag, vbSunday) > 1 Then
    
        strFehler = "Berechnungsfehler: Ostersonntag " & _
         "liegt nicht an einem Sonntag!"
        
        Ostersonntag = strFehler & vbCrLf & "Berechnungergebnis: " _
         & Format(Ostersonntag, "dd.MM.yyyy", vbSunday)
    End If
Else

    Ostersonntag = strFehler
End If

End Function

Private Function getMundN(ByRef bytM As Byte, ByRef bytN As Byte, _
 lngJahr As Long) As String
 
getMundN = ""

Select Case lngJahr
    Case 1582 To 1699:
        bytM = 22
        bytN = 2
    Case 1700 To 1799:
        bytM = 23
        bytN = 3
    Case 1800 To 1899:
        bytM = 23
        bytN = 4
    Case 1900 To 2099:
        bytM = 24
        bytN = 5
    Case 2100 To 2199:
        bytM = 24
        bytN = 6
    Case 2200 To 2299:
        bytM = 25
        bytN = 0
    Case 2300 To 2399:
        bytM = 26
        bytN = 1
    Case 2400 To 2499:
        bytM = 25
        bytN = 1
Case Else
    getMundN = "Die Jahreszahl muss zwischen 1581 und 2500 liegen!"
End Select
End Function

Public Function Ostermontag(lngJahr As Long) As Variant
    Dim varTemp As Variant
    varTemp = Ostersonntag(lngJahr)
    If IsDate(varTemp) Then
        Ostermontag = DateAdd("d", 1, varTemp)
    Else
        Ostermontag = varTemp 'Fehlermeldung zurückgeben
    End If
End Function
Public Function Karfreitag(lngJahr As Long) As Variant
    Dim varTemp As Variant
    varTemp = Ostersonntag(lngJahr)
    If IsDate(varTemp) Then
        Karfreitag = DateAdd("d", -2, varTemp)
    Else
        Karfreitag = varTemp 'Fehlermeldung zurückgeben
    End If
End Function
Public Function Pfingstsonntag(lngJahr As Long) As Variant
    Dim varTemp As Variant
    varTemp = Ostersonntag(lngJahr)
    If IsDate(varTemp) Then
        Pfingstsonntag = DateAdd("d", 49, varTemp)
    Else
        Pfingstsonntag = varTemp 'Fehlermeldung zurückgeben
    End If
End Function
Public Function Pfingstmontag(lngJahr As Long) As Variant
    Dim varTemp As Variant
    varTemp = Ostersonntag(lngJahr)
    If IsDate(varTemp) Then
        Pfingstmontag = DateAdd("d", 50, varTemp)
    Else
        fingstmontag = varTemp 'Fehlermeldung zurückgeben
    End If
End Function
Public Function Rosenmontag(lngJahr As Long) As Variant
    Dim varTemp As Variant
    varTemp = Ostersonntag(lngJahr)
    If IsDate(varTemp) Then
        Rosenmontag = DateAdd("d", -48, varTemp)
    Else
        Rosenmontag = varTemp 'Fehlermeldung zurückgeben
    End If
End Function
Public Function Fastnacht(lngJahr As Long) As Variant
    Dim varTemp As Variant
    varTemp = Ostersonntag(lngJahr)
    If IsDate(varTemp) Then
        Fastnacht = DateAdd("d", -47, varTemp)
    Else
        Fastnacht = varTemp 'Fehlermeldung zurückgeben
    End If
End Function
Public Function Aschermittwoch(lngJahr As Long) As Variant
    Dim varTemp As Variant
    varTemp = Ostersonntag(lngJahr)
    If IsDate(varTemp) Then
        Aschermittwoch = DateAdd("d", -46, varTemp)
    Else
        Aschermittwoch = varTemp 'Fehlermeldung zurückgeben
    End If
End Function
Public Function Himmelfahrt(lngJahr As Long) As Variant
    Dim varTemp As Variant
    varTemp = Ostersonntag(lngJahr)
    If IsDate(varTemp) Then
        Himmelfahrt = DateAdd("d", 39, varTemp)
    Else
        Himmelfahrt = varTemp 'Fehlermeldung zurückgeben
    End If
End Function
Public Function Fronleichnam(lngJahr As Long) As Variant
        Dim varTemp As Variant
        varTemp = Ostersonntag(lngJahr)
    If IsDate(varTemp) Then
        Fronleichnam = DateAdd("d", 60, varTemp)
    Else
        Fronleichnam = varTemp 'Fehlermeldung zurückgeben
    End If
End Function
'############################################################
    'Zum Lesen der Datei reicht eine private Prozedur,
        'der Sie den Dateinamen einschließlich des Pfads
        'der Textdatei übergeben
Private Sub FeiertageLesen(strDateiname As String)

Dim lngDatei As Long
Dim strFehler As String
Dim strZeile As String
Dim varZeile As Variant
Dim lngZeile As Long

On Error GoTo FEHLER

lngDatei = FreeFile()

    ' Datei öffnen.
Open strDateiname For Input As #lngDatei

    'Auslesen der Einträge und einfügen in das Array
ReDim arrFTage(1)
lngZeile = -1

    'lesen sie in einer Schleife zeilenweise aus
    'Schleife bis Dateiende.
Do While Not EOF(lngDatei)
    Input #lngDatei, strZeile
    
    If Trim(strZeile) > "" Then
        On Error Resume Next
        
            'Jede Zeile splitten Sie mit Hilfe der Split-Funktion in ein Array
        varZeile = Split(strZeile, ";")
        
        typFTag.Tag = varZeile(0)
        typFTag.Monat = varZeile(1)
        typFTag.Name = varZeile(2)
        typFTag.Land = varZeile(3)
        
        On Error GoTo FEHLER
    
    End If
    
        'Array vergrößern
    lngZeile = lngZeile + 1
    arrFTage(lngZeile) = typFTag
    ReDim Preserve arrFTage(UBound(arrFTage) + 1)
    Debug.Print strZeile
Loop

Close #lngDatei

    'Texdatei öffnen
Exit Sub

'---------------------------------------------------------
FEHLER:

If Err.Number = 52 Then
    strFehler = "Die Datei " & strDateiname & _
    " ist nicht vorhanden oder kann nicht geöffnet werden!"
End If

    'Debug.Print Err.Number & ": " & Err.Description
If strFehler > "" Then
    On Error Resume Next
    MsgBox strFehler
    Close #lngDatei
    Exit Sub
End If

End Sub

Public Function FixFeiertag(datDatum As Date, _
    strDateiname As String, Optional strLand) As String
    
    'Prüft ob es sich bei dem Datum um einen fixen Feiertag handelt
    'Falls ja, wird der Name des Feiertags zurückgegeben
    
Dim bytFehler As Byte
Dim bytTag As Byte
Dim bytMonat As Byte
Dim lngZage

bytFehler = 0
FixFeiertag = ""

On Error GoTo FEHLER

    'Array durchsuchen
        'weil bei einem noch nicht initialisierten Array
        'das Abrufen der oberen Indexgrenze mit ubound einen
        'Laufzeitfehler verursacht.
If UBound(arrFTage) >= 0 Then
        'zunächst aus dem Parameter datDatum der Tag
            'und der Monat ermittelt und in zwei Variablen gespeichert
    bytTag = Day(datDatum)
    bytMonat = Month(datDatum)
    
        'Danach durchläuft eine Schleife das Array.
            'Für den Fall, dass der optionale Parameter strLand
            'nicht übergeben wurde, wird nur geprüft,
            'ob Monat und Tag des aktuellen Array-Eintrags mit den Werten
            'in den beiden Variablen übereinstimmen
        'Wird zusätzlich das Land angegeben, wird auch dieses in die Prüfung einbezogen.
    For lngZeile = LBound(arrFTage) To UBound(arrFTage)
        typFTag = arrFTage(lngZeile)
        
        If IsMissing(strLand) Then
        
            If (bytTag = typFTag.Tag) _
            And (bytMonat = typFTag.Monat) Then
                    'der Name des Feiertags als Rückgabewert festgelegt
                FixFeiertag = typFTag.Name
                Exit For
            End If
            
        Else
    
            If (bytTag = typFTag.Tag) _
            And (bytMonat = typFTag.Monat) _
            And (strLand = typFTag.Land) Then
                    'der Name des Feiertags als Rückgabewert festgelegt
                FixFeiertag = typFTag.Name
                Exit For
            End If
            
        End If
        
    Next lngZeile ' <- befindet sich im For oder nicht?
End If

Exit Function

'---------------------------------------------------------
FEHLER:
    'Ist dies die Zahl 9, war das Array noch nicht initialisiert
        'und die Prozedur FeiertageLesen wird aufgerufen
bytFehler = bytFehler + 1
If Err.Number = 9 Then
    If bytFehler = 1 Then
        FeiertageLesen strDateiname
        Resume
    Else
        Exit Function
    End If
End If

End Function





'Methoden zum Erfassen von Feiertagen
'Wenn Sie dem Benutzer der Anwendung, der die Klasse verwendet,
'die Möglichkeit geben möchten, feste Feiertage über ein Formular
'oder eine UserForm zu erfassen, sollten Sie dazu schon in der
'Klasse eine Methode vorsehen, die an die Textdatei eine Zeile
'mit neuen Werten anhängt. Diese Methode soll hier
'FeierTagSchreiben lauten (Listing 4). Ihr übergeben Sie die zu
'schreibenden Werte für die einzelne Spalte sowie den Dateinamen
'und den Pfad der Textdatei. Die Methode schreibt diese Daten
'dann in die Textdatei.
Public Sub FeierTagSchreiben(strDateiname As String, _
 bytTag As Byte, bytMonat As Byte, strName As String, strLand As String)

Dim lngDatei As Long
Dim strFehler As String
Dim strZeile As String
Dim varZeile As Variant
Dim lngZeile As Long
Dim bytFehler As Byte
bytFehler = 0

On Error GoTo FEHLER

lngDatei = FreeFile()
    'Datei öffnen.
Open strDateiname For Append As #lngDatei
    'Textdatei öffnen und Daten schreiben
Print #lngDatei, bytTag & ";" & bytMonat & ";" & strName & ";" & strLand
Close #lngDatei

Exit Sub

'---------------------------------------------------------
FEHLER:
bytFehler = bytFehler + 1
If Err.Number = 52 Then
    strFehler = "Die Datei " & strDateiname & _
     " ist nicht vorhanden oder kann nicht geöffnet werden!"
ElseIf Err.Number = 55 Then
    If bytFehler < 5 Then
        Resume
    Else
        strFehler = "In die Datei konnte nicht geschrieben werden!"
    End If
End If
        
If strFehler > "" Then
    On Error Resume Next
    MsgBox strFehler
    Close #lngDatei
    
    Exit Sub
End If

End Sub