MS-Office-Forum

Zurück   MS-Office-Forum > Microsoft Access & Datenbanken > Microsoft Access - MOF-FAQ > MOF-FAQ - Module/VBA/VBE
Registrieren Forum Hilfe Alle Foren als gelesen markieren

Banner und Co.

 
Ads
Themen-Optionen Ansicht
Alt 01.02.2003, 05:29   #1
Stefan Kulpa
MOF Meister
MOF Meister
Normal Wie ermittle ich die Feiertage eines Jahres?

Code:

Option Explicit
'// ----------------------------------------------------------------
'// Feiertagsberechnung nach dem Algorithmus von Carl Friedrich Gauß
'// ----------------------------------------------------------------
Type DtFeiertage
     Jahreszahl         As Long
     Ostern             As Date
     Neujahr            As Date
     DreiKoenige        As Date
     Rosenmontag        As Date
     Aschermittwoch     As Date
     Karfreitag         As Date
     Ostersonntag       As Date
     Ostermontag        As Date
     Maifeiertag        As Date
     ChrHimmelfahrt     As Date
     Pfingstsonntag     As Date
     Pfingstmontag      As Date
     Fronleichnam       As Date
     MariaeHimmelfahrt  As Date
     DtEinheit          As Date
     Reformationstag    As Date
     Allerheiligen      As Date
     Heiligabend        As Date
     Weihnachten1       As Date
     Weihnachten2       As Date
     Sylvester          As Date
End Type
 
Dim m_uDTF As DtFeiertage
 
Sub Beispiel()
 
    Call BerechneFeiertage(Year(Now))
    Debug.Print "Die Feiertage für   "; Year(Now); vbCrLf
    Debug.Print "Neujahr             "; Format(m_uDTF.Neujahr, "Long Date")
    Debug.Print "Hl. Drei Könige     "; Format(m_uDTF.DreiKoenige, "Long Date")
    Debug.Print "Rosenmontag         "; Format(m_uDTF.Rosenmontag, "Long Date")
    Debug.Print "Aschermittwoch      "; Format(m_uDTF.Aschermittwoch, "Long Date")
    Debug.Print "Karfreitag          "; Format(m_uDTF.Karfreitag, "Long Date")
    Debug.Print "Ostersonntag        "; Format(m_uDTF.Ostersonntag, "Long Date")
    Debug.Print "Ostermontag         "; Format(m_uDTF.Ostermontag, "Long Date")
    Debug.Print "Maifeiertag         "; Format(m_uDTF.Maifeiertag, "Long Date")
    Debug.Print "Christi Himmelfahrt "; Format(m_uDTF.ChrHimmelfahrt, "Long Date")
    Debug.Print "Pfingstsonntag      "; Format(m_uDTF.Pfingstsonntag, "Long Date")
    Debug.Print "Pfingstmontag       "; Format(m_uDTF.Pfingstmontag, "Long Date")
    Debug.Print "Fronleichnam        "; Format(m_uDTF.Fronleichnam, "Long Date")
    Debug.Print "Mariä Himmelfahrt   "; Format(m_uDTF.MariaeHimmelfahrt, "Long Date")
    Debug.Print "Tag der dt. Einheit "; Format(m_uDTF.DtEinheit, "Long Date")
    Debug.Print "Reformationstag     "; Format(m_uDTF.Reformationstag, "Long Date")
    Debug.Print "Allerheiligen       "; Format(m_uDTF.Allerheiligen, "Long Date")
    Debug.Print "Heiligabend         "; Format(m_uDTF.Heiligabend, "Long Date")
    Debug.Print "Weihnachten1        "; Format(m_uDTF.Weihnachten1, "Long Date")
    Debug.Print "Weihnachten2        "; Format(m_uDTF.Weihnachten2, "Long Date")
    Debug.Print "Sylvester           "; Format(m_uDTF.Sylvester, "Long Date")
'// ----------------------------------------------------------------
'// Ausgabe:
'// ----------------------------------------------------------------
'// Neujahr             Mittwoch, 1. Januar 2003
'// Hl. Drei Könige     Montag, 6. Januar 2003
'// Rosenmontag         Montag, 3. März 2003
'// Aschermittwoch      Mittwoch, 5. März 2003
'// Karfreitag          Freitag, 18. April 2003
'// Ostersonntag        Sonntag, 20. April 2003
'// Ostermontag         Montag, 21. April 2003
'// Maifeiertag         Donnerstag, 1. Mai 2003
'// Christi Himmelfahrt Donnerstag, 29. Mai 2003
'// Pfingstsonntag      Sonntag, 8. Juni 2003
'// Pfingstmontag       Montag, 9. Juni 2003
'// Fronleichnam        Donnerstag, 19. Juni 2003
'// Mariä Himmelfahrt   Freitag, 15. August 2003
'// Tag der dt. Einheit Freitag, 3. Oktober 2003
'// Reformationstag     Freitag, 31. Oktober 2003
'// Allerheiligen       Samstag, 1. November 2003
'// Heiligabend         Mittwoch, 24. Dezember 2003
'// Weihnachten1        Donnerstag, 25. Dezember 2003
'// Weihnachten2        Freitag, 26. Dezember 2003
'// Sylvester           Mittwoch, 31. Dezember 2003
'// ----------------------------------------------------------------
End Sub
 
Sub BerechneFeiertage(Jahreszahl As Integer)
 
'// Als Refrenzdatum zunächst m_uDTF.Ostern berechnen
    If Not Ostern_berechnen(Jahreszahl) Then Exit Sub
 
'// Neujahr setzen (fester Feiertag am 1. Januar)
    m_uDTF.Neujahr = DateSerial(Jahreszahl, 1, 1)
 
'// Hl. Drei Könige setzen (fester Feiertag am 6. Januar)
    m_uDTF.DreiKoenige = DateSerial(Jahreszahl, 1, 6)
 
'// Rosenmontag berechnen (beweglicher Feiertag; 48 Tage vor Ostern)
    m_uDTF.Rosenmontag = m_uDTF.Ostern - 48
 
'// Aschemittwoch berechnen (beweglicher Feiertag; 46 Tage vor Ostern)
    m_uDTF.Aschermittwoch = m_uDTF.Ostern - 46
 
'// Karfreitag berechnen (beweglicher Feiertag; 2 Tage vor Ostern)
    m_uDTF.Karfreitag = m_uDTF.Ostern - 2
 
'// Ostersonntag = m_uDTF.Ostern!
    m_uDTF.Ostersonntag = m_uDTF.Ostern
 
'// Ostermontag berechnen (beweglicher Feiertag; 1 Tag nach Ostern)
    m_uDTF.Ostermontag = m_uDTF.Ostern + 1
 
'// Maifeiertag setzen (fester Feiertag am 1. Mai)
    m_uDTF.Maifeiertag = DateSerial(Jahreszahl, 5, 1)
 
'// Christi Himmelfahrt berechnen (beweglicher Feiertag; 39 Tage nach Ostern)
    m_uDTF.ChrHimmelfahrt = m_uDTF.Ostern + 39
 
'// Pfingstsonntag berechnen (beweglicher Feiertag; 49 Tage nach Ostern)
    m_uDTF.Pfingstsonntag = m_uDTF.Ostern + 49
 
'// Pfingstmontag berechnen (beweglicher Feiertag; 50 Tage nach Ostern)
    m_uDTF.Pfingstmontag = m_uDTF.Ostern + 50
 
'// Fronleichnam berechnen (beweglicher Feiertag; 60 Tage nach Ostern)
    m_uDTF.Fronleichnam = m_uDTF.Ostern + 60
 
'// Mariä Himmelfahrt setzen (fester Feiertag am 15. August)
    m_uDTF.MariaeHimmelfahrt = DateSerial(Jahreszahl, 8, 15)
 
'// Tag der deutschen Einheit setzen (fester Feiertag am 3. Oktober)
    m_uDTF.DtEinheit = DateSerial(Jahreszahl, 10, 3)
 
'// Reformationstag setzen (fester Feiertag am 31. Oktober)
    m_uDTF.Reformationstag = DateSerial(Jahreszahl, 10, 31)
 
'// Allerheiligen setzen (fester Feiertag am 1. November)
    m_uDTF.Allerheiligen = DateSerial(Jahreszahl, 11, 1)
 
'// Heiligabend setzen (fester 'Feiertag' am 24. Dezember)
    m_uDTF.Heiligabend = DateSerial(Jahreszahl, 12, 24)
 
'// Erster Weihnachtstag setzen (fester 'Feiertag' am 25. Dezember)
    m_uDTF.Weihnachten1 = DateSerial(Jahreszahl, 12, 25)
 
'// Zweiter Weihnachtstag setzen (fester 'Feiertag' am 26. Dezember)
    m_uDTF.Weihnachten2 = DateSerial(Jahreszahl, 12, 26)
 
'// Sylvester setzen (fester 'Feiertag' am 31. Dezember)
    m_uDTF.Sylvester = DateSerial(Jahreszahl, 12, 31)
 
End Sub
 
Function Ostern_berechnen(ByVal lYear As Long) As Boolean
 
'// Berechnung mit Hilfe des Algorithmus von Gauß
    On Error GoTo Err_Ostern_berechnen
 
    Dim i1  As Integer
    Dim i2  As Integer
    Dim i3  As Integer
    Dim i4  As Integer
    Dim i5  As Integer
    Dim iTZ As Integer                            '// iTZ = Tageszahl
 
    i1 = lYear Mod 19                             '// Formel nach Gauß
    i2 = lYear Mod 4                              '// Werte für die Jahre
    i3 = lYear Mod 7                              '// 1900 - 2099
 
    i4 = (19 * i1 + 24) Mod 30
    i5 = (2 * i2 + 4 * i3 + 6 * i4 + 5) Mod 7
    iTZ = 22 + i4 + i5                            '// Ermittelt den Tag
    If iTZ > 31 Then                              '// März oder April
        iTZ = iTZ - 31                            '// Wenn April, dann - 31 Tage
        If iTZ = 26 Then iTZ = 19                 '// Wenn 26.4. dann 19.4.
        If (iTZ = 25 And i4 = 28 And i1 > 10) Then iTZ = 18
        m_uDTF.Ostern = DateSerial(lYear, 4, iTZ) '// Ostern im April
    Else
        m_uDTF.Ostern = DateSerial(lYear, 3, iTZ) '// Ostern im Maerz
    End If
    Ostern_berechnen = True
 
Exit_Ostern_berechnen:
    Exit Function
 
Err_Ostern_berechnen:
    Ostern_berechnen = False
    GoTo Exit_Ostern_berechnen
 
End Function
Code eingefügt mit dem MOF Code Converter
Angehängte Dateien
Dateityp: txt feiertage.txt (7,7 KB, 1558x aufgerufen)

__________________

Stefan
Stefan Kulpa ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Ads
 


Aktive Benutzer in diesem Thema: 1 (Registrierte Benutzer: 0, Besucher: 1)
 
Themen-Optionen
Ansicht

Forumregeln
Es ist Ihnen nicht erlaubt, neue Themen zu verfassen.
Es ist Ihnen nicht erlaubt, auf Beiträge zu antworten.
Es ist Ihnen nicht erlaubt, Anhänge anzufügen.
Es ist Ihnen nicht erlaubt, Ihre Beiträge zu bearbeiten.

vB Code ist An.
Smileys sind An.
[IMG] Code ist An.
HTML-Code ist An.
Gehe zu


Alle Zeitangaben in WEZ +1. Es ist jetzt 21:40 Uhr.



Powered by: vBulletin Version 3.6.2 (Deutsch)
Copyright ©2000 - 2019, Jelsoft Enterprises Ltd.

Copyright ©2000-2018 MS-Office-Forum. Alle Rechte vorbehalten.
Copyright ©Design: Manuela Kulpa ©Rechte: Günter Kramer
Eine Verwendung der Inhalte in anderen Publikationen, auch auszugsweise,
ist ohne ausdrückliche Zustimmung der Autoren nicht gestattet.