VBA Tipp: Tierkreiszeichen berechnen

Aus DBWiki
Wechseln zu: Navigation, Suche

Aufgabenstellung

Ich möchte das Tierkreiszeichen (Sternzeichen) zu einem Geburtsdatum ermitteln.

Lösung

In voller Schönheit ist die Berechnung sehr aufwändig - speziell in den Grenzbereichen zwischen den einzelnen Zeichen:

'  Nach der JavaScript-Routine von Dr. Rüdiger Plantiko
'  (http://www.phoenix-astrologie.de/sonnenstand.js)
'
'  Nützliche Algorithmen von der Art der folgenden, hier aufgeführten,
'  findet man in dem Buch von Oliver Montenbruck, Grundlagen der
'  Ephemeridenrechnung, Verlag Sterne und Weltraum, München 1987,
'  ISBN 3-87973-913-7
 
Function SinG(A As Double) As Double
   'Sinus von Gradwert
   SinG = sIn(A * 0.017453292519942)
End Function
 
Function CosG(A As Double) As Double
   'Cosinus von Gradwert
   CosG = Cos(A * 0.017453292519942)
End Function
 
Function Fract(A As Double) As Double
   'Dezimalteil
   Fract = (A - Int(A))
End Function
 
Function DeltaT(x As Double) As Double
   'Differenz ET-UT in Ephemeridentagen, Formel ist genau für
   'die Jahre von 1900 - 1985
 
   Dim t As Double
 
   t = (x / 1# - 2451545#) / 36525#
   If -1 <= t And t <= 0 Then
      DeltaT = (((((-339.84 * t - 516.52) * t - 160.22) * t + 92.23) * t + 71.28) / 86400#)
   Else
   'Keine Funktion verfuegbar - besser als nichts
      DeltaT = 1 / 1440#
   End If
End Function
 
Function Nutation(x As Double) As Double
   'Nutation in Laenge in Bogensekunden
 
   Dim o As Double
 
   o = 125.045 - 1934.136 * (x / 1# - 2451545#) / 36525#
   Nutation = (-17.2 * SinG(o) + 0.206 * SinG(o + o))
End Function
 
'Dekanatnummer
Function Dekanat(Laenge As Double) As Double
   Dekanat = Int((Laenge - 30# * Int(Laenge / 30)) / 10) + 1
End Function
 
Function xjd(di As Integer, mi As Integer, yi As Integer, _
             sti As Integer, mii As Integer, sei As Integer) As Double
   'Kalenderdatum in Julianisches Datum umwandeln
   'Uhrzeit in MEZ
 
   Dim x As Double
   Dim b As Double
 
   'Eingabechecks
   If (1 > di) Or _
      (31 < di) Or _
      ((28 < di) And (mi = 2)) Or _
      ((30 < di) And ((mi = 4) Or (mi = 6) Or (mi = 9) Or (mi = 11))) Then
      MsgBox "Ungültige Tagesangabe"
      Exit Function
   ElseIf ((1 > mi) Or (12 < mi)) Then
      MsgBox ("Ungültige Monatsangabe")
      Exit Function
   ElseIf ((-2000 > yi) Or (3000 < yi)) Then
      MsgBox "Ungültige Jahresangabe"
      Exit Function
   End If
 
   'Kalenderdatum in Julianisches Datum umwandeln
   'Uhrzeit in MEZ
   If (mi <= 2#) Then
      mi = mi / 1# + 12#
      yi = yi / 1# - 1#
   End If
   b = -2#
 
   'Stichtag für Verwendung des Gregorianischen Kalenders
   If (di / 370# + mi / 12# + yi / 1# > 1582.87117) Then
      b = Int(yi / 400#) - Int(yi / 100#)
   End If
   x = Int(365.25 * yi) + Int(30.6001 * (mi / 1# + 1#)) + b + 1720996.45833333
   x = x + di / 1#
   x = x + sti / 24#
   x = x + mii / 1440#
   x = x + sei / 86400#
   x = x + DeltaT(x) 'Korrektur UT in ET verwandeln
   xjd = x
End Function
 
Function Sonnenlaenge(xjd As Double) As Double
   'Sonnenlaenge nach Newcomb
   Const pi2 = 6.28318530717959
 
   Dim C As Double, T1 As Double, T As Double, dlp As Double
   Dim a_ As Double, D As Double, U As Double, g As Double, g2 As Double, g4 As Double
   Dim g5 As Double, g6 As Double, dl As Double, dl2 As Double, dl4 As Double
   Dim dl6 As Double, dlm As Double, L As Double
   Dim l0 As Double, l01 As Double, dl5 As Double
 
   C = pi2 / 360#
 
   'Lichtlaufzeit
   T1 = xjd - 0.00578 - 2415020#
   T = T1 / 36525#
 
   'long periodic disturbation
   dlp = (1.882 - 0.016 * T) _
       * SinG(57.24 + 150.27 * T) + 6.4 _
       * SinG(231.19 + 20.2 * T) _
       + 0.266 * SinG(31.8 + 119# * T)
 
   'mean longitude sun
   l0 = 279.6966778 + 360# * Fract(T1 / 365.25)
   l01 = 2768.13 * T + 1.089 * T * T + 0.202 * SinG(315.6 + 893.3 * T) + dlp
   l0 = l0 + l01 / 3600#
   'mean anomaly sun
   g = 358.475833 _
     + 360# * Fract(T1 * 2.71047227926078E-03) _
     + T1 * 9.82888432580424E-03 _
     + (179.1 * T - 0.54 * T * T + dlp) / 3600#
 
   'mean anomaly venus,mars,jupiter,saturn
   g2 = 212.45 + 360# * Fract(T1 * 0.004435318275154) _
      + T1 * 5.4070636650308E-03
 
   g4 = 319.58 + T1 * 0.524024010951403
 
   g5 = 225.28 + T1 * 8.30823545516769E-02 _
      + 0.361111111111111 * SinG(133.775 + 39.804 * T)
 
   g6 = 175.6 + T1 * 3.34508966461328E-02
 
   'moon data
   D = 350.737486 + T1 * 8.40832900752909E-03 _
     + 360# * Fract(T1 * 3.38398357289528E-02)
 
   a_ = 296.104608 + T1 * 5.44419186858316E-03 _
      + 360# * Fract(T1 * 3.62765229295003E-02)
 
   U = 11.250889 + T1 * 2.24572621492128E-03 _
     + 360# * Fract(T1 * 3.67419575633128E-02)
 
   'terms of two body motion
   dl = (6910.057 - 17.24 * T) * SinG(g) _
      + (72.338 - 0.361 * T) * SinG(2# * g) _
      + 1.054 * T * SinG(3# * g)
 
   'perturbations in longitude
   dl2 = 4.838 * CosG(299.102 + g2 - g) _
       + 0.116 * CosG(148.9 + 2# * g2 - g) _
       + 5.526 * CosG(148.313 + 2# * g2 - 2# * g) _
       + 2.497 * CosG(315.943 + 2# * g2 - 3# * g) _
       + 0.666 * CosG(177.71 + 3# * g2 - 3# * g) _
       + 1.559 * CosG(345.243 + 3# * g2 - 4# * g) _
       + 1.024 * CosG(318.15 + 3# * g2 - 5# * g) _
       + 0.21 * CosG(206.2 + 4# * g2 - 4# * g) _
       + 0.144 * CosG(195.4 + 4# * g2 - 5# * g) _
       + 0.152 * CosG(343.8 + 4# * g2 - 6# * g) _
       + 0.123 * CosG(195.3 + 5# * g2 - 7# * g) _
       + 0.154 * CosG(359.6 + 5# * g2 - 8# * g)
 
   dl4 = 0.273 * CosG(217.7 - g4 + g) _
       + 2.043 * CosG(343.888 - 2# * g4 + 2# * g) _
       + 1.77 * CosG(200.402 - 2# * g4 + g) _
       + 0.129 * CosG(294.2 - 3# * g4 + 3# * g) _
       + 0.425 * CosG(338.8 - 3# * g4 + 2# * g) _
       + 0.5 * CosG(105.18 - 4# * g4 + 3# * g) _
       + 0.585 * CosG(334.06 - 4# * g4 + 2# * g) _
       + 0.204 * CosG(100.8 - 5# * g4 + 3# * g) _
       + 0.154 * CosG(227.4 - 6# * g4 + 4# * g) _
       + 0.101 * CosG(96.3 - 6# * g4 + 3# * g) _
       + 0.106 * CosG(222.7 - 7# * g4 + 4# * g)
 
   dl5 = 0.163 * CosG(198.6 - g5 + 2# * g) _
       + 7.208 * CosG(179.532 - g5 + g) _
       + 2.6 * CosG(263.217 - g5) _
       + 2.731 * CosG(87.145 - 2# * g5 + 2# * g) _
       + 1.61 * CosG(109.493 - 2# * g5 + g) _
       + 0.164 * CosG(170.5 - 3# * g5 + 3# * g) _
       + 0.556 * CosG(82.65 - 3# * g5 + 2# * g) _
       + 0.21 * CosG(98.5 - 3# * g5 + g)
 
   dl6 = 0.419 * CosG(100.58 - g6 + g) _
       + 0.32 * CosG(269.46 - g6) _
       + 0.108 * CosG(290.6 - 2# * g6 + 2# * g) _
       + 0.112 * CosG(293.6 - 2# * g6 + g)
 
   dlm = 6.454 * SinG(D) _
       + 0.177 * SinG(D + a_) _
       - 0.424 * SinG(D - a_) _
       + 0.172 * SinG(D - g)
 
   'now sum up to true longitude
   L = dl + dl2 + dl4 + dl5 + dl6 + dlm
   L = L + Nutation(xjd)
   L = Fract((L / 3600# + l0) / 360#) * 360#
 
   Sonnenlaenge = L
End Function
 
Function Zeichen(Laenge As Double) As String
   'Tierkreiszeichen aus Laenge
   Select Case Int(Laenge / 30#)
   Case 0:  Zeichen = "Widder"
   Case 1:  Zeichen = "Stier"
   Case 2:  Zeichen = "Zwillinge"
   Case 3:  Zeichen = "Krebs"
   Case 4:  Zeichen = "Loewe"
   Case 5:  Zeichen = "Jungfrau"
   Case 6:  Zeichen = "Waage"
   Case 7:  Zeichen = "Skorpion"
   Case 8:  Zeichen = "Schuetze"
   Case 9:  Zeichen = "Steinbock"
   Case 10: Zeichen = "Wassermann"
   Case 11: Zeichen = "Fische"
   End Select
End Function
 
Function ZeichenW(Laenge As Double)
   'Tierkreiszeichen in Unicode
   ZeichenW = ChrW(Int(Laenge / 30#) + &H2648)
End Function
 
Function TierkreisZeichenText(D As Date) As String
   Dim Juldat As Double, L As Double
 
   Juldat = xjd(day(D), Month(D), Year(D), Hour(D), minute(D), Second(D))
   L = Sonnenlaenge(Juldat)
   TierkreisZeichenText = Zeichen(L)
End Function
 
Function TierkreisZeichenUnicode(D As Date)
   Dim Juldat As Double, L As Double
 
   Juldat = xjd(day(D), Month(D), Year(D), Hour(D), minute(D), Second(D))
   L = Sonnenlaenge(Juldat)
   TierkreisZeichenUnicode = ZeichenW(L)
End Function

Aufruf

Z.B. im Direktfenster:

Debug.Print TierkreisZeichenText #1965-7-14#

Oder als Steuerelementinhalt eines Textfelds (mit einer Unicode-Schriftart):

=TierkreisZeichenUnicode([Geburtsdatum])

Anmerkung

Über Sinn oder Unsinn der Astrologie im Allgemeinen und der Tierkreiszeichen im Speziellen soll damit nichts gesagt sein. Näheres findet sich auf einschlägigen Astrologieseiten wie z.B. http://www.phoenix-astrologie.de.

Wer die Sternzeichen und andere Planetenberechnungen supergenau berechnen will, der findet übrigens unter http://www.astro.com/swisseph einen Satz freier DLLs und (notwendiger) Planetendaten-Dateien. Aber etwas Einarbeitung in die Materie ist dann leider schon notwendig...