VBA Tipp: Julianisches Datum ermitteln, Kalenderkonvertierungen, u.a.m.

Aus DBWiki
Wechseln zu: Navigation, Suche

Anforderung

Ich will mit dem in der Astronomie gebräuchlichen Julianischen Datum (beginnend mit dem 1. Januar 4713 v. Chr. 12 Uhr) arbeiten, sowie Konvertierungen eines Datums zwischen Julianischem Kalender, iki/Gregorianischer_Kalender Gregorianischem Kalender, des Islamischem Kalender und Jüdischem Kalenders vornehmen.

Lösung

Jean Meeus hat in seinem Buch Astronomical Algorithms ein entsprechendes Formelwerk veröffentlicht, das im folgenden VBA-Modul umgesetzt ist. An einigen Stellen wird von der Funktion Modf() Gebrauch gemacht, die man deshalb für die Verwendung des nachfolgenden Codes auch benötigt.

'Quelle: http://www.dbwiki.net/
'
'Das Formelwerk stammt überwiegend aus 'Astronomical Algorithms' 2. Aufl.,
'von Jean Meeus - in Kommentaren als AA abgekürzt.
'
'Geklmmerte Zahlen verweisen auf Kapitel und Formelnummer.
'
 
Option Explicit
 
 
'------------------------------------------------------------------------------
'CalendarGregorianToJD konvertiert ein gregorianisches Jahr, Monat und Tag des
'Monats in einen Julianischen Tag.
'
'Negative Jahre sind gültig, bis auf JD 0, das Ergebnis ist nicht gültig für
'Daten vor JD 0.
Public Function CalendarGregorianToJD(ByVal y As Long, ByVal m As Long, _
                                      ByVal d As Double) As Double
   Dim a As Long
   Dim b As Long
 
   Select Case m
   Case 1, 2: y = y - 1: m = m + 12
   End Select
 
   a = Int(y / 100)
   b = 2 - a + Int(a / 4)
   'AA (7.1), S.61
   CalendarGregorianToJD = Int(365.25 * (y + 4716)) _
                         + Int(30.6 * (m + 1)) + b + d - 1524.5
End Function
'------------------------------------------------------------------------------
 
 
'------------------------------------------------------------------------------
'CalendarJulianToJD konvertiert ein Julianisches Jahr, Monat und Tag des Monats
'in einen Julianischen Tag.
'
'Negative Jahre sind gültig, bis JD 0, das Ergebnis ist nicht gültig für Daten
'vor JD 0.
Public Function CalendarJulianToJD(ByVal y As Long, ByVal m As Long, _
                                   ByVal d As Double) As Double
   Select Case m
   Case 1, 2: y = y - 1: m = m + 12
   End Select
   'wie in CalendarGregorianToJD, nur dass b entfällt
   CalendarJulianToJD = Int(365.25 * (y + 4716)) _
                      + Int(30.6 * (m + 1)) + d - 1524.5
End Function
'------------------------------------------------------------------------------
 
 
'------------------------------------------------------------------------------
'LeapYearJulian gibt true zurück, wenn das Jahr y im Julianischen Kalender ein
'Schaltjahr ist.
Public Function LeapYearJulian(ByVal y As Long) As Boolean
   'AA S.62
   LeapYearJulian = y Mod 4 = 0
End Function
'------------------------------------------------------------------------------
 
 
'------------------------------------------------------------------------------
'LeapYearGregorian gibt true zurück, wenn das Jahr y im Gregorianischen
'Kalender ein Schaltjahr ist.
Public Function LeapYearGregorian(ByVal y As Long) As Boolean
   'AA S.62
   LeapYearGregorian = (y Mod 4 = 0 And y Mod 100 <> 0) Or (y Mod 400 = 0)
End Function
'------------------------------------------------------------------------------
 
 
'------------------------------------------------------------------------------
'JDtoCalendar liefert das Kalenderdatum für das angegebene jd.
'
'Hinweis: Diese Methode gibt ein Datum im Julianischen oder
'         Gregorianischen Kalender zurück.
Public Sub JDtoCalendar(ByVal jd As Double, ByRef y As Long, _
                        ByRef m As Long, ByRef d As Double)
   Dim f     As Double
   Dim zf    As Double
   Dim z     As Long
   Dim a     As Long
   Dim alpha As Long
   Dim b     As Long
   Dim c     As Long
   Dim d_    As Long
   Dim e     As Long
 
   'AA S.63
 
   f = Modf(jd + 0.5, zf)
   z = zf
   a = z
 
   If z >= 2299151 Then  'erstes Datum nach der gregorianischen Kalenderreform
      alpha = Int((z - 1867216.25) / 36524.25)
      a = z + 1 + alpha - Int(alpha / 4)
   End If
 
   b = a + 1524
   c = Int((b - 122.1) / 365.25)
   d_ = Int(365.25 * c)
   e = Int((b - d_) / 30.6001)
 
   d = b - d_ - Int(30.6001 * e) + f
 
   Select Case e
   Case 14, 15: m = e - 13
   Case Else:   m = e - 1
   End Select
 
   Select Case m
   Case 1, 2: y = c - 4715
   Case Else: y = c - 4716
   End Select
End Sub
'------------------------------------------------------------------------------
 
 
'------------------------------------------------------------------------------
'JDtoCalendarGregorian gibt das Gregorianische Kalenderdatum für das angegebene
'JD zurück.
 
'Hinweis: Es wird ein Gregorianisches Datum auch für Daten vor dem Beginn des
'         Gregorianischen Kalenders zurückgegeben.  Die Funktion ist nützlich
'         bei der Arbeit mit VBA Date Werten, weil diese immer auf dem
'         Gregorianischen Kalender basieren.
Public Sub JDtoCalendarGregorian(ByVal jd As Double, ByRef y As Long, _
                                 ByRef m As Long, ByRef d As Double)
   Dim f     As Double
   Dim zf    As Double
   Dim z     As Long
   Dim alpha As Long
   Dim a     As Long
   Dim b     As Long
   Dim c     As Long
   Dim d_    As Long
   Dim e     As Long
 
   'AA S.63
 
   f = Modf(jd + 0.5, zf)
   z = zf
   alpha = Int((z - 1867216.25) / 36524.25)
   a = z + 1 + alpha - Int(alpha / 4)
   b = a + 1524
   c = Int((b - 122.1) / 365.25)
   d_ = Int(365.25 * c)
   e = Int((b - d_) / 30.6001)
 
   d = b - d_ - Int(30.6001 * e) + f
   Select Case e
   Case 14, 15: m = e - 13
   Case Else: m = e - 1
   End Select
 
   Select Case m
   Case 1, 2: y = c - 4715
   Case Else: y = c - 4716
   End Select
End Sub
'------------------------------------------------------------------------------
 
 
'------------------------------------------------------------------------------
'JDtoDate wandelt ein Julianisches Datum in einen VBA-Datumswert.
'
'Die Zeit ist als UTC zu betrachten.
Public Function JDtoDate(ByVal jd As Double) As Date
   Dim y As Long
   Dim m As Long
   Dim d As Double
   Dim f As Double
 
   JDtoCalendarGregorian jd, y, m, d
   If y < 100 Or Year > 9999 Then _
      Err.Raise 6, , "Datumsbereich ist zu klein oder zu groß."
   f = Modf(d, d)
   JDtoDate = DateSerial(y, m, d) + CDate(f)
 
End Function
'------------------------------------------------------------------------------
 
 
'------------------------------------------------------------------------------
'DatetoJD wandelt ein VBA-Datum in ein Julianisches Datum um.
'
'Die Zeit wird als UTC behandelt.
Public Function DatetoJD(ByVal dt As Date) As Double
   DatetoJD = CalendarGregorianToJD(Year(dt), Month(dt), day(dt) + TimeValue(dt))
End Function
'------------------------------------------------------------------------------
 
 
'------------------------------------------------------------------------------
'DayOfWeek bestimmt den Wochentag für ein bestimmtes JD.
'
'Der zurückgegebene Wert ist eine ganze Zahl im Bereich von 0 bis 6,
'wobei 0 für Sonntag steht.  Dies ist die gleiche Konvention wie im
'VBA DateTime Modul.
Public Function DayOfWeek(ByVal jd As Double) As VbDayOfWeek
   'AA S.65
   DayOfWeek = Int(jd + 1.5) Mod 7
End Function
'------------------------------------------------------------------------------
 
 
'------------------------------------------------------------------------------
'DayOfYearGregorian berechnet die Tageszahl innerhalb des Jahres des
'Gregorianischen Kalenders.
Public Function DayOfYearGregorian(ByVal y As Long, ByVal m As Long, _
                                   ByVal d As Long) As Long
   'AA S.65, 66
   DayOfYearGregorian = DayOfYear(y, m, d, LeapYearGregorian(y))
End Function
'------------------------------------------------------------------------------
 
 
'------------------------------------------------------------------------------
'DayOfYearJulian berechnet die Tageszahl innerhalb des Jahres des
'Julianischen Kalenders.
Public Function DayOfYearJulian(ByVal y As Long, ByVal m As Long, _
                                ByVal d As Long) As Long
   'AA S.65
   DayOfYearJulian = DayOfYear(y, m, d, LeapYearJulian(y))
End Function
'------------------------------------------------------------------------------
 
 
'------------------------------------------------------------------------------
'DayOfYear berechnet die Tageszahl innerhalb des Jahres.
'
'Diese Form der Funktion ist nicht spezifisch für den Julianischen oder
'Gregorianischen Kalender, aber Sie müssen ihr sagen, ob das Jahr ein
'Schaltjahr ist.
Public Function DayOfYear(ByVal y As Long, ByVal m As Long, _
                                ByVal d As Long, ByVal leap As Boolean) As Long
   Dim k As Long
 
   'AA S.65
   k = 2 + leap
   DayOfYear = WholeMonths(m, k) + d
End Function
'------------------------------------------------------------------------------
 
 
'------------------------------------------------------------------------------
'DayOfYearToCalendar liefert den Kalendermonat und -tag
'für einen bestimmten Tag im Jahr und Schaltjahr.
Public Sub DayOfYearToCalendar(ByVal n As Long, ByVal leap As Boolean, _
                               ByRef m As Long, ByRef d As Long)
   Dim k As Long
 
   'AA S.66
   k = 2 + leap
   If n < 32 Then
      m = 1
   Else
      m = Int(9 * (k + n) / 275 + 0.98)
   End If
   d = n - WholeMonths(m, k)
End Sub
'------------------------------------------------------------------------------
 
 
'------------------------------------------------------------------------------
'Hilfsfunktion für DayOfYear und DayOfYearToCalendar
Private Function WholeMonths(ByVal m As Long, ByVal k As Long) As Long
   'AA S.65, 66
   WholeMonths = Int(275 * m / 9) - k * Int((m + 9) / 12) - 30
End Function
'------------------------------------------------------------------------------
 
 
'------------------------------------------------------------------------------
'HebrewCalendar liefert interessante Daten und Fakten über ein bestimmtes Jahr.
 
'Eingabe ist ein julianisches oder gregorianisches Jahr.
'
'Ausgabe:
'   a:      Jahreszahl im Jüdischen Kalender
'   mP:     Monatsnummer des Pessach.
'   dP:     Tageszahl von Pessach.
'   mNY:    Monatsnummer des jüdischen Neujahrs.
'   dNY:    Tagesnummer des jüdischen Neujahrs.
'   months: Anzahl der Monate in diesem Jahr.
'   days:   Anzahl der Tage in diesem Jahr.
Public Sub HebrewCalendar(ByVal y As Long, ByRef a As Long, _
                          ByRef mP As Long, ByRef dP As Long, _
                          ByRef mNY As Long, ByRef dNY As Long, _
                          ByRef months As Long, ByRef days As Long)
   Dim d  As Long
   Dim y1 As Long
 
   'AA S.71, 72
   a = y + 3760
   d = BigD(y)
   mP = 3
   dP = d
   If dP > 31 Then
      mP = mP + 1
      dP = dP - 31
   End If
   'Eine Vereinfachung von Meeus' Regel, um 163 Tage hinzuzufügen.
   'Monate von Pessach sind entweder März oder April mit d basierend auf März.
   'Monate des neuen Jahres sind entweder September oder August, so dass
   'd + 163 - (Tage von März bis September = 184) = d - 21 ab September
   'basieren muss.
   mNY = 9
   dNY = d - 21
   If dNY > 30 Then
      mNY = mNY + 1
      dNY = dNY - 30
   End If
   months = 12
   Select Case a Mod 19
   Case 0, 3, 6, 8, 11, 14, 17: months = months + 1
   End Select
   'Ebenso eine Vereinfachung von Meeus' Regel, um die Differenz in
   'Kalendertagen von NY eines Jahres zu NY des nächsten zu nehmen.
   'NY basiert auf d, also ist der Unterschied in d der Unterschied
   'in den Tageszahlen des Jahres.  Ergebnis ist die Summe aus dieser
   'Zahl und der Anzahl der Tage im westlichen Kalenderjahr.
   days = 365
   y1 = y + 1
   If y1 < 1583 Then
      If LeapYearJulian(y1) Then days = days + 1
   Else
      If LeapYearGregorian(y1) Then days = days + 1
   End If
   days = days + BigD(y1) - d
End Sub
'------------------------------------------------------------------------------
 
 
'------------------------------------------------------------------------------
'Hilfsmethode wird mehrmals von HebrewCalendar aufgerufen
Private Function BigD(ByVal y As Long) As Long
   Dim c  As Long
   Dim s  As Long
   Dim a  As Long
   Dim b  As Long
   Dim d  As Long
   Dim q  As Double
   Dim fq As Double
   Dim iq As Long
   Dim j  As Long
   Dim r  As Double
 
   'AA S.71, 72
   c = Int(y / 100)
   If y >= 1583 Then s = Int((3 * c - 5) / 4)
   a = (12 * y + 12) Mod 19
   b = y Mod 4
   q = -1.904412361576 + 1.554241796621 * a _
     + 0.25 * b _
     - 0.003177794022 * y _
     + s
   fq = Int(q)
   iq = Int(fq)
   j = (iq + 3 * y + 5 * b + 2 - s) Mod 7
   r = q - fq
 
   Select Case True
   Case j = 2 Or j = 4 Or j = 6:               d = iq + 23
   Case j = 1 And a > 6 And r >= 0.63287037:   d = iq + 24
   Case j = 0 And a > 11 And r >= 0.897723765: d = iq + 23
   Case Else: d = iq + 22
   End Select
 
   BigD = d
End Function
'------------------------------------------------------------------------------
 
 
'------------------------------------------------------------------------------
'GregorianToJulian nimmt ein Jahr, Monat und Tag des
'Gregorianischen Kalenders und gibt das entsprechende
'Jahr, Monat und Tag des Julianischen Kalenders zurück.
Public Sub GregorianToJulian(ByVal y As Long, ByVal m As Long, ByVal d As Long, _
                             ByRef jy As Long, ByRef jm As Long, ByRef jd As Long)
   Dim alpha As Long
   Dim beta  As Long
   Dim b     As Long
 
   If m < 3 Then y = y - 1: m = m + 12
 
   alpha = Int(y / 100)
   beta = 2 - alpha + Int(alpha / 4)
   b = Int(365.25 * y) + Int(30.6001 * (m + 1)) + d + 1722519 + beta
 
   ymd b, jy, jm, jd
 
End Sub
'------------------------------------------------------------------------------
 
 
'------------------------------------------------------------------------------
'JulianToGregorian konvertiert eine julianische Kalenderjahr-
'und Tagesnummer in ein Jahr, einen Monat und einen Tag im
'Gregorianischen Kalender.
Public Sub JulianToGregorian(ByVal y As Long, ByVal dn As Long, _
                             ByRef gy As Long, ByRef gm As Long, ByRef gd As Long)
   Dim jd    As Long
   Dim alpha As Long
   Dim beta  As Long
   Dim b     As Long
 
   jd = Int(365.25 * (y - 1)) + 1721423 + dn
   alpha = Int((jd - 1867216.25) / 36524.25)
   beta = jd
   If jd >= 2299161 Then beta = beta + 1 + alpha - Int(alpha / 4)
   b = beta + 1524
 
   ymd b, gy, gm, gd
 
End Sub
'------------------------------------------------------------------------------
 
 
'------------------------------------------------------------------------------
'Hilfsmethode für JulianToGregorian
Private Sub ymd(ByVal b As Long, ByRef y As Long, _
                ByRef m As Long, ByRef d As Long)
   Dim c As Long
   Dim e As Long
 
   c = Int((b - 122.1) / 365.25)
   d = Int(365.25 * c)
   e = Int((b - d) / 30.6001)
   ' berechne Rückgaben
   d = b - d - Int(30.6001 * e)
   If e < 14 Then m = e - 1 Else m = e - 13
   If m > 2 Then y = c - 4716 Else y = c - 4715
End Sub
'------------------------------------------------------------------------------
 
 
'------------------------------------------------------------------------------
'IslamicToJulian konvertiert ein islamisches Kalenderdatum in
'eine Julianische Jahres- und Tageszahl.
Public Sub IslamicToJulian(ByVal y As Long, ByVal m As Long, ByVal d As Long, _
                         ByRef jy As Long, ByRef jDN As Long)
   Dim n  As Long
   Dim q  As Long
   Dim r  As Long
   Dim a  As Long
   Dim W  As Long
   Dim q1 As Long
   Dim q2 As Long
   Dim g  As Long
   Dim k  As Long
   Dim e  As Long
   Dim j  As Long
   Dim x  As Long
 
   'AA S.74
   n = d + Int(29.5001 * (m - 1) + 0.99)
   q = Int(y / 30)
   r = y Mod 30
   a = Int((11 * r + 3) / 30)
   W = 404 * q + 354 * r + 208 + a
   q1 = Int(W / 1461)
   q2 = W Mod 1461
   g = 621 + 28 * q + 4 * q1
   k = Int(q2 / 365.2422)
   e = Int(365.2422 * k)
   j = q2 - e + n - 1
   x = g + k
 
   Select Case True
   Case j > 366 And x Mod 4 = 0: j = j - 366: x = x - 1
   Case j > 365 And x Mod 4 > 0: j = j - 365: x = x + 1
   End Select
 
   jy = x: jDN = j
End Sub
'------------------------------------------------------------------------------
 
 
'------------------------------------------------------------------------------
'IslamicLeapYear gibt true zurück, wenn das Jahr y des
'islamischen Kalenders ein Schaltjahr ist.
Public Function IslamicLeapYear(ByVal y As Long) As Boolean
   Dim r As Long
 
   r = y Mod 30
   IslamicLeapYear = (11 * r + 3) Mod 30 > 18
End Function
'------------------------------------------------------------------------------
 
 
'------------------------------------------------------------------------------
'JulianToIslamic nimmt ein Jahr, Monat und Tag des Julianischen Kalenders und
'gibt das entsprechende Jahr, Monat und Tag des islamischen Kalenders zurück.
Public Sub JulianToIslamic(ByVal y As Long, ByVal m As Long, ByVal d As Long, _
                         ByRef iy As Long, ByRef im As Long, ByRef id As Long)
   Dim a    As Long
   Dim b    As Long
   Dim W    As Long
   Dim n    As Long
   Dim c    As Long
   Dim c1   As Double
   Dim c2   As Long
   Dim dP   As Long
   Dim q    As Long
   Dim r    As Long
   Dim j    As Long
   Dim k    As Long
   Dim o    As Long
   Dim h    As Long
   Dim jj   As Long
   Dim days As Long
   Dim s    As Long
 
   'AA S.75
   W = 2
   If y Mod 4 = 0 Then W = 1
   n = Int(275 * m / 9) - W * Int((m + 9) / 12) + d - 30
   a = y - 623
   b = Int(a / 4)
   c = a Mod 4
   c1 = 365.25001 * c
   c2 = Int(c1)
   If c1 - c2 > 0.5 Then c2 = c2 + 1
   dP = 1461 * b + 170 + c2
   q = Int(dP / 10631)
   r = dP Mod 10631
   j = Int(r / 354)
   k = r Mod 354
   o = Int(11 * j + 14 / 30)
   h = 30 * q + j + 1
   jj = k - o + n - 1
   days = 354
 
   If IslamicLeapYear(y) Then days = days + 1
   If jj > days Then jj = jj - days: h = h + 1
   iy = h
   If jj = 355 Then
      im = 12
      id = 30
   Else
      s = Int((jj - 1) / 29.5)
      im = 1 + s
      id = Int(jj - 29.5 * s)
   End If
End Sub
'------------------------------------------------------------------------------
 
 
#Const UNICODE = False   'zur Ausgabe im Direktfenster auf False setzen
'------------------------------------------------------------------------------
'IslamicMonthname gibt den romanisierten Monatsnamen zurück.
Public Function IslamicMonthname(ByVal im As Long) As String
   Static IMonths As Variant
 
   If Not IsArray(IMonths) Then
      #If UNICODE Then
         IMonths = Array("Mu" & ChrW$(&H1E25) & "arram", _
                         ChrW$(&H1E62) & "afar", _
                         "Rab" & ChrW$(&H12B) & ChrW$(&H2BF) & " I", _
                         "Rab" & ChrW$(&H12B) & ChrW$(&H2BF) & " II", _
                         "Jum" & ChrW$(&H101) & "d" & ChrW$(&H101) & " I", _
                         "Jum" & ChrW$(&H101) & "d" & ChrW$(&H101) & " II", _
                         "Rajab", _
                         "Sha" & ChrW$(&H2BF) & "ban", _
                         "Rama" & ChrW$(&H1E0D) & ChrW$(&H101) & "n", _
                         "Shaww" & ChrW$(&H101) & "l", _
                         "Dh" & ChrW$(&H16B) & " al-Qa" & ChrW$(&H2BF) & "da", _
                         "Dh" & ChrW$(&H16B) & " al-" & ChrW$(&H1E24) & "ijja")
      #Else
         IMonths = Array("Muharram", "Safer", "Rabi' I", "Rabi' II", _
                         "Jumada I", "Jumada II", "Rajab", "Sha'ban", _
                         "Ramadan", "Shawwal", "Dhu al-Qa'da", "Dhu al-Hijja")
      #End If
   End If
   Select Case im
   Case 0 To 11: IslamicMonthname = IMonths(im - 1)
   End Select
End Function
'------------------------------------------------------------------------------

Beispiele

Sub Beispiel_CalendarGregorianToJD_sputnik()
   'AA 7.a, S.61
   Dim jd As Double
 
   jd = CalendarGregorianToJD(1957, 10, 4.81)
   Debug.Print Format$(jd, "0.00")
   'Ausgabe:
   '2436116,31
End Sub
 
Sub Beispiel_CalendarGregorianToJD_halley()
   'AA 7.c, S.64
   Dim jd1 As Double
   Dim jd2 As Double
 
   jd1 = CalendarGregorianToJD(1910, 4, 20)
   jd2 = CalendarGregorianToJD(1986, 2, 9)
   Debug.Print Format$(jd2 - jd1, "0 Tag\e")
   'Ausgabe:
   '27689 Tage
End Sub
 
Sub Test_Greg()
   Dim data, a, dt#
 
   data = Array(Array(2000, 1, 1.5, 2451545), _
                Array(1999, 1, 1, 2451179.5), _
                Array(1987, 1, 27, 2446822.5), _
                Array(1987, 6, 19.5, 2446966), _
                Array(1988, 1, 27, 2447187.5), _
                Array(1988, 6, 19.5, 2447332), _
                Array(1900, 1, 1, 2415020.5), _
                Array(1600, 1, 1, 2305447.5), _
                Array(1600, 12, 31, 2305812.5))
 
   For Each a In data
      dt = CalendarGregorianToJD(a(0), a(1), a(2)) - a(3)
      If Abs(dt) > 0.1 Then
         Debug.Print "Fatal: "; Format(dt * 24, "0.00\ "); "Stunden"
      End If
   Next
End Sub
 
Sub Beispiel_CalendarJulianToJD()
   'AA 7.b, S.61
   Dim jd As Double
 
   jd = CalendarJulianToJD(333, 1, 27.5)
   Debug.Print Format$(jd, "0.0")
   'Ausgabe:
   '1842713,0
End Sub
 
Sub Test_Juli()
   'AA S.62
   Dim data, a, dt As Double
 
   data = Array(Array(837, 4, 10.3, 2026871.8), _
                Array(-123, 12, 31, 1676496.5), _
                Array(-122, 1, 1, 1676497.5), _
                Array(-1000, 7, 12.5, 1356001), _
                Array(-1000, 2, 29, 1355866.5), _
                Array(-1001, 8, 17.9, 1355671.4), _
                Array(-4712, 1, 1.5, 0))
 
   For Each a In data
      dt = CalendarJulianToJD(a(0), a(1), a(2)) - a(3)
      If Abs(dt) > 0.1 Then
         Debug.Print "Fatal: dt = " & Format$(dt * 24, "0.00 Stunden")
      End If
   Next
End Sub
 
Sub Test_JuliLeap()
   Dim data, a
 
   data = Array(Array(900, True), _
                Array(1236, True), _
                Array(750, False), _
                Array(1429, False))
 
   For Each a In data
      If LeapYearJulian(a(0)) <> a(1) Then
         Debug.Print "Fatal: LeapYearJulian"
      End If
   Next
End Sub
 
Sub Test_GregLeap()
   Dim data, a
 
   data = Array(Array(1700, False), _
                Array(1800, False), _
                Array(1900, False), _
                Array(2100, False), _
                Array(1600, True), _
                Array(2000, True), _
                Array(2400, True))
 
   For Each a In data
      If LeapYearGregorian(a(0)) <> a(1) Then
         Debug.Print "Fatal: LeapYearGregorian"
      End If
   Next
End Sub
 
Sub Beispiel_JDtoCalendar()
   'AA 7.c, S.64
   Dim y&, m&, d#
 
   JDtoCalendar 2436116.31, y, m, d
   Debug.Print y; MonthName(m); " "; Format$(d, "0.00")
   'Ausgabe:
   '1957 Oktober 4,81
End Sub
 
Sub Test_YMD()
   Dim data, a, y&, m&, d#
 
   data = Array(Array(1842713, 333, 1, 27.5), _
                Array(1507900.13, -584, 5, 28.63))
 
   For Each a In data
      JDtoCalendar a(0), y, m, d
      If y <> a(1) Or m <> a(2) Or Abs(d - a(3)) > 0.01 Then
         Debug.Print "Fatal:"; y; m; d
      End If
   Next
End Sub
 
Sub Beispiel_DayOfWeek()
   'AA 7.e, S.65
   Debug.Print WeekdayName(DayOfWeek(2434923.5))
   'Ausgabe:
   'Mittwoch
End Sub
 
Sub Beispiel_DayOfYear_f()
   'AA 7.f, S.65
   Debug.Print DayOfYear(1978, 11, 14, False)
   'Ausgabe:
   '316
End Sub
 
Sub Beispiel_DayOfYear_g()
   'AA 7.g, S.65
   Debug.Print DayOfYear(1988, 4, 22, True)
   'Ausgabe:
   '113
End Sub
 
Sub Test_DOYtoCal()
   Dim data, a, m&, d&
 
   data = Array(Array(1978, 11, 14, False, 318), _
                Array(1988, 4, 22, True, 113))
 
   For Each a In data
      DayOfYearToCalendar a(4), a(3), m, d
      If m <> a(1) Or d <> a(2) Then
         Debug.Print "Fatal: DayOfYearToCalendar "; m; d
      End If
   Next
End Sub
 
Sub Beispiel_HebrewCalendar()
   'AA 9.a, S.73
   Dim a&, mP&, dP&, mNY&, dNY&, months&, days&
 
   HebrewCalendar 1990, a, mP, dP, mNY, dNY, months, days
   Debug.Print "Hebr Jahr:"; a
   Debug.Print "Pessach:   "; MonthName(mP); dP
   Debug.Print "Neu Year:  "; MonthName(mNY); dNY
   Debug.Print "Monate:   "; months
   Debug.Print "Tage:     "; days
   'Ausgabe:
   'Montate:   12
   'Tage:      354
   'Hebr Jahr: 5750
   'Pessach:   April 10
   'Neu Year:  September 20
   'Monate:    12
   'Tage:      354
End Sub
 
Sub Beispiel_IslamicToJulian()
   'AA 9.b, S.75
   Dim y&, dn&
 
   IslamicToJulian 1421, 1, 1, y, dn
   Debug.Print y; dn
   'Ausgabe:
   '2000  84
End Sub
 
Sub Beispiel_JulianToGregorian()
   'AA 9.b, S.75 conversion to Gregorian
   Dim y&, m&, d&
 
   JulianToGregorian 2000, 84, y, m, d
   Debug.Print d; MonthName(m); y
   'Ausgabe:
   '6 April 2000
End Sub
 
Sub Beispiel_IslamicLeapYear()
   'AA 9.b, S.75 indication of leap year
   If IslamicLeapYear(1421) Then
      Debug.Print "Das Islamische Jahr 1421 ist ein Schaltjahr mit 355 Tagen."
   Else
      Debug.Print "Das Islamische Jahr 1421 ist ein normales Jahr mit 354 Tagen."
   End If
   'Ausgabe:
   'Das Islamische Jahr 1421 ist ein normales Jahr mit 354 Tagen.
End Sub
 
Sub Beispiel_GregorianToJulian()
   'AA 9.c, S.76 conversion to Julian Calendar
   Dim y&, m&, d&
 
   GregorianToJulian 1991, 8, 13, y, m, d
   Debug.Print y; MonthName(m); " "; d; "Julian"
   'Ausgabe:
   '1991 Juli  31 Julian
End Sub
 
Sub Beispiel_JulianToIslamic()
   'AA 9.c, S.76 final output
   Dim y&, m&, d&
 
   JulianToIslamic 1991, 7, 31, y, m, d
   Debug.Print d; IslamicMonthname(m); " d. H."; y
   'Ausgabe:
   '2 Safer d. H. 1412
End Sub

Wikilinks