feiertage berechnen / calculate holidays

berot3 (berot3) — Fri, 10 Aug 2007 14:31:42 GMT
// noch nicht fertig


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
DZone Snippets: vba code

feiertage berechnen / calculate holidays
