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, 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...