// 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
