title image


Smiley Das ist nicht ganz einfach ...
wenn man es korrekt machen will (wobei ich mich jeglicher Kommentare zu Sternkreiszeichen und der Verwendung des Wortes "korrekt" in diesem Zusammenhang enthalte...):



' 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, l0 As Double, l01 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, dl5 As Double

Dim dl6 As Double, dlm As Double, L 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





Wenn du einen entsprechenden Unicode-Font verwendest, kannst du die Routine direkt einsetzen, separate Bilder brauchst du dann nicht (wenngleich das natürlich ziemlich rechenlastig ist ;{)


Gruß aus dem Norden
Reinhard


Bitte immer die Access-Version angeben!
DB-Wiki


Wie man Fragen richtig stellt

YaccessAccess-FAQUnd ansonsten: Wikipedia




geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: