Dieser Algorithmus wurde mit Hilfe der entsprechenden Wikipedia - Seite erstellt. Mir war wichtig, dass alle Zwischenergebnisse sichtbar gemacht werden. Auch evtl Korrekturen werden in extra - Labels angezeigt. Viel Spaß damit. Folgende Steuerelemente werden benötigt:
Den gesamten Code kopieren und in eine leere Form einfügen. Alle Steuerelemente auf eine Form ziehen. Beschriftung, Größe und Anordnung übernimmt der Code. Option Explicit Dim Start As Boolean Private Sub Form_Load() ' alle Steuerelemente positionieren Dim i As Integer Start = True Me.Height = 9930 Me.Width = 6320 Me.Caption = "Kalenderberechnungen" For i = 0 To 2 Combo1(i).Top = 720 Next i For i = 3 To 5 Combo1(i).Top = 5400 Next i For i = 0 To 3 With Label1(i) .Width = 3495 .Height = 255 .Left = 240 .ForeColor = vbBlue End With Next i Label1(0).Top = 120 Label1(0).Caption = "Julianisch -> Julianisches Datum (JD)" Label1(1).Top = 2640 Label1(1).Caption = "Julianisches Datum -> Julianischer Kalender" Label1(2).Top = 4800 Label1(2).Caption = "Gregorianisch -> Julianisches Datum (JD)" Label1(3).Top = 7320 Label1(3).Caption = "Julianisches Datum -> Gregorianischer Kalender" With Combo1(0) For i = 1 To 31 .AddItem Format$(i, "00") Next i .Width = 615 .Left = 240 .Text = "01" End With With Combo1(1) For i = 1 To 12 .AddItem Format$(i, "00") Next i .Width = 615 .Left = 1080 .Text = "01" End With With Combo1(2) For i = 1 To 1582 .AddItem i Next i .Width = 975 .Left = 1920 .Text = 1582 End With With Combo1(3) For i = 1 To 31 .AddItem Format$(i, "00") Next i .Width = 615 .Left = 240 .Text = "01" End With With Combo1(4) For i = 1 To 12 .AddItem Format$(i, "00") Next i .Width = 615 .Left = 1080 .Text = "01" End With With Combo1(5) For i = 1582 To 2100 .AddItem i Next i .Width = 975 .Left = 1920 .Text = Right(Date, 4) End With For i = 0 To 1 Text1(i).Width = 1815 Text1(i).Height = 285 Text1(i).Left = 3120 Next i Text1(0).Top = 720 Text1(1).Top = 5400 Text1(0).Text = "" Text1(1).Text = "" For i = 0 To 1 lblWT(i).Width = 1335 lblWT(i).Height = 255 lblWT(i).Left = 4440 lblWT(i).Caption = "Wochentag" Next i lblWT(0).Top = 120 lblWT(1).Top = 4800 For i = 0 To 1 Label2(i).Height = 255 Label2(i).Width = 4695 Label2(i).Left = 240 Label2(i).Caption = "Tag Monat " & _ "Jahr Jul. Datum (JD)" Next i Label2(0).Top = 480 Label2(1).Top = 5160 For i = 0 To 3 With lblJul(i) .Height = 614 .Width = 5655 .Left = 240 End With Next i lblJul(0).Caption = "Zwischenergebnisse" lblJul(2).Caption = "Zwischenergebnisse" lblJul(1).Caption = "Zwischenergebnisse korrigiert" lblJul(3).Caption = "Zwischenergebnisse korrigiert" lblJul(0).Top = 1200 lblJul(1).Top = 1920 lblJul(2).Top = 3000 lblJul(3).Top = 3720 For i = 0 To 3 With lblGreg(i) .Height = 614 .Width = 5655 .Left = 240 End With Next i lblGreg(0).Caption = "Zwischenergebnisse" lblGreg(2).Caption = "Zwischenergebnisse" lblGreg(1).Caption = "Zwischenergebnisse korrigiert" lblGreg(3).Caption = "Zwischenergebnisse korrigiert" lblGreg(0).Top = 5880 lblGreg(1).Top = 6600 lblGreg(2).Top = 7680 lblGreg(3).Top = 8400 For i = 0 To 3 Command1(i).Height = 255 Command1(i).Width = 615 Command1(i).Left = 5280 Command1(i).Caption = "Start" Next i Command1(0).Top = 720 Command1(1).Top = 2640 Command1(2).Top = 5400 Command1(3).Top = 7320 Start = False End Sub Private Sub Combo1_Change(Index As Integer) If Start = False Then If Combo1(2) <> "-" Then If Combo1(2) = 0 Then MsgBox "Das Jahr 0 gibt es nicht", vbExclamation, "Kalender" Combo1(2) = 1 Exit Sub End If End If End If If Index = 2 Or Index = 5 Then Combo1(Index).ToolTipText = "" End Sub Private Sub Combo1_Click(Index As Integer) If Combo1(2) <> "-" Then If Combo1(2) = 0 Then MsgBox "Das Jahr 0 gibt es nicht", vbExclamation, "Kalender" Combo1(2) = 1 Exit Sub End If End If If Index = 2 Or Index = 5 Then Combo1(Index).ToolTipText = "" End Sub Private Sub Command1_Click(Index As Integer) Dim M ' Monat Dim T ' Tag Dim J ' Jahr Dim MK ' Monatskorrektur Dim SK ' Schaltjahreskorrektur Dim LT ' Laufender Tag Dim LJ ' Laufendes Jahr Dim N4 ' Anzahl der vollen 4-Jahres-Zyklen (N4) seit dem Startjahr Dim N1 ' Anzahl der vollen Jahre (N1) im letzten, unvollständigen 4-Jahres-Zyklus Dim JD ' Julianisches Datum nach Joseph Justus Scaliger (1540 - 1609) Dim R4 ' Anzahl Tage des letzten, unvollständigen 4-Jahres-Zyklus berechnet Dim N400 ' Anzahl der vollen 4-Jahres-Zyklen seit Startjahr Dim R400 ' Anzahl Tage des letzten, unvollständigen 400-Jahres-Zyklus Dim N100 ' Anzahl der vollen 100-Jahres-Zyklen des letzten 400-Jahres-Zyklus Dim R100 ' Anzahl der vollen Jahre im letzten, unvollständigen 100-Jahres-Zyklus Dim JD0 ' Das Julianische Datum des ertsen Januar des Jahres 1 ist JD0 = 1721426 Dim M1 Dim T1 Select Case Index Case 0 Combo1(2).ToolTipText = "" lblJul(0) = "" lblJul(1) = "" ' Das Julianische Datum zählt die Tage seit dem 1. Januar 4713 v. Chr. ' (JD = 0) -> 3267 n. Chr. durch ' = 7980 Jahre ' In dieser Rechnung wird das Startjahr des Julianischen Datums ' auf 4716 v. Chr. vorverlegt, da die Schaltjahre dann am Ende eines ' 4-Jahres-Zyklus liegen und sich sich die Rechnung vereinfacht. Als ' laufendes Jahr (LJ) wird die Anzahl Jahre ab diesem Startjahr bezeichnet. ' Für 4716 v. Chr. ist LJ=0, für 4715 v. Chr. ist LJ=1 usw. T = Combo1(0) M = Combo1(1) J = Combo1(2) ' Schaltjahr ermitteln If IstSchaltjahrJul(Combo1(2)) Then Combo1(2).ToolTipText = "Schaltjahr" ' Korrekturwert Schaltjahr ermitteln If IstSchaltjahrJul(Combo1(2)) And M > 2 Then SK = 1 Else SK = 0 End If ' Laufendes Jahr ermitteln If Combo1(2) < 0 Then LJ = 4716 + J ' (für vorchristliche Jahre) Else LJ = 4715 + J ' (für nachchristliche Jahre) End If N4 = Int(LJ / 4) ' (ganzzahlig) N1 = LJ Mod 4 ' Rest dieser Division ' Monatskorrektur ermitteln MK = Monatskorrektur(M) ' Laufender Tag LT = T + 30 * (M - 1) + (SK + MK) ' Die Umkehrung (Ermittlung des Datums bei gegebenem LT) ist: M1 = Int((LT + 1) / 30 + 1) ' (ganzzahlig) T1 = LT - 30 * (M1 - 1) - (SK + MK) ' Julianisches Datum errechnen ' (1461 ist die Länge eines 4-Jahres-Zyklus, 365 die Länge eines ' Normaljahres. ' Die 3 wird von N1 abgezogen, um die Vorverlegung des Startjahres ' auszugleichen) ' siehe oben in dieser Prozedur JD = 1461 * N4 + 365 * (N1 - 3) + LT ' Zwischenergebnisse eintragen ' Bei einigen Werten von LT ergibt die Formel für M einen um 1 zu großen Wert. ' Das macht sich durch M=13 oder T<1 bemerkbar. In diesen Fällen müssen ' die Werte für M und T korrigiert werden. ' Falls (M>12) oder (T<1): vermindere M um 1 und berechne T erneut If M1 > 12 Or T1 < 1 Then lblJul(1).Caption = "M1 = " & M1 & " T1 = " & T1 M1 = M1 - 1 T1 = LT - 30 * (M1 - 1) - (SK + MK) End If lblJul(0) = "T = " & T & " M = " & M & _ " J = " & J & " SK = " & SK & _ " MK = " & MK & " LT = " & LT & _ " LJ = " & LJ & " ( M = " & M1 & _ " T = " & T1 & " ) N4 = " & N4 & _ " N1 = " & N1 & _ " ( Probe: N4 x 4 = " & N4 * 4 & " ) " Text1(0) = JD lblWT(0).Caption = Wochentag(Int((JD + 1.5)) Mod 7) lblWT(0).ToolTipText = Int((JD + 1.5)) Mod 7 Case 1 If IsNumeric(Text1(0)) = False Then MsgBox "Das Julianische Datum fehlt", vbExclamation, "Kalender" Exit Sub End If lblJul(2) = "" lblJul(3) = "" JD = Text1(0) ' Um ein Datum des Julianischen Kalenders bei gegebenem Julianischen Datum ' zu berechnen, werden zunächst die Anzahl der vollen 4-Jahres-Zyklen (N4) ' seit dem Startjahr und die Anzahl Tage (R4) des letzten, unvollständigen ' 4-Jahres-Zyklus berechnet: N4 = Int((JD + 1095) / 1461) ' (ganzzahlig) R4 = (JD + 1095) Mod 1461 ' Rest obiger Division ' (Durch Addition von 1095 (3*365) wird das Startjahr um drei Jahre vorverlegt.) ' Als nächstes wird die Anzahl der vollen Jahre (N1) des unvollständigen ' 4-Jahres-Zyklus berechnet, sowie der laufende Tag (LT) im letzten Jahr: N1 = Int(R4 / 365) ' (ganzzahlig) LT = R4 Mod 365 ' N1 kann zwischen 0 und 3 liegen. Am letzten Tag des Zyklus ergibt die ' Rechnung N1=4 und LT=0. In diesem Fall müssen die Werte korrigiert werden: ' falls (N1=4) setze N1=3 und LT=365 If N1 = 4 Then ' Zwischenergebnis festhalten lblJul(3).Caption = "N1 = " & N1 N1 = 3 And LT = 365 End If ' Das laufende Jahr LJ ergibt sich zu: LJ = 4 * N4 + N1 ' Die Berechnung der Jahreszahl (J) aus LJ ergibt sich durch: If LJ <= 4715 Then J = (4716 - LJ) * -1 ' v. Chr. (für LJ <= 4715) If LJ > 4715 Then J = LJ - 4715 ' n. Chr. (für LJ > 4715) ' Monat ermitteln bei gegebenem LT M = Int((LT + 1) / 30 + 1) ' (ganzzahlig) ' Monatskorrektur ermitteln MK = Monatskorrektur(M) ' Korrekturwert Schaltjahr ermitteln If IstSchaltjahrJul(J) And M > 2 Then SK = 1 Else SK = 0 End If T = LT - 30 * (M - 1) - (SK + MK) If MK = "" Then MK = "?" ' Bei einigen Werten von LT ergibt die Formel für M einen um 1 zu großen Wert. ' Das macht sich durch M=13 oder T<1 bemerkbar. In diesen Fällen müssen ' die Werte für M und T korrigiert werden: ' falls (M>12) oder (T<1): vermindere M um 1 und berechne T erneut If M > 12 Or T < 1 Then lblJul(3).Caption = lblJul(3).Caption & " M = " & M & " T = " & T M = M - 1 MK = Monatskorrektur(M) ' Korrekturwert Schaltjahr ermitteln If IstSchaltjahrJul(J) And M > 2 Then SK = 1 Else SK = 0 End If T = LT - 30 * (M - 1) - (SK + MK) End If lblJul(2).Caption = "N4 = " & N4 & " R4 = " & R4 & _ " N1 = " & N1 & " LT = " & LT & _ " LJ = " & LJ & _ " SK = " & SK & " MK = " & MK & _ " J = " & J & " ( M = " & M & _ " T = " & T & " ) " & T & "." & M & "." & J Case 2 Combo1(5).ToolTipText = "" ' Schaltjahr ermitteln If IstSchaltjahrGreg(Combo1(5)) Then Combo1(5).ToolTipText = "Schaltjahr" lblGreg(0).Caption = "" lblGreg(1).Caption = "" JD0 = 1721426 T = Combo1(3) M = Combo1(4) J = Combo1(5) ' Laufender Tag ermitteln ' In dieser Rechnung wird die Tageszählung seit Jahresanfang, ' beginnend mit 0, laufender Tag (LT) genannt. Für den 1. Januar ' ist LT = 0, für den 31. Dezember LT=365 (Normaljahr) bzw. ' ' LT=366 (Schaltjahr). ' Korrekturwert Schaltjahr ermitteln If IstSchaltjahrGreg(Combo1(5)) And M > 2 Then SK = 1 Else SK = 0 End If ' Monatskorrektur ermitteln MK = Monatskorrektur(M) ' Laufender Tag LT = T + 30 * (M - 1) + (SK + MK) ' Die Umkehrung (Ermittlung des Datums bei gegebenem LT) ist: M1 = Int((LT + 1) / 30 + 1) ' (ganzzahlig) T1 = LT - 30 * (M1 - 1) - (SK + MK) ' Laufendes Jahr ' In dieser Rechnung wird der Anfang des Gregorianischen Kalenders ' auf den 1. Januar des Jahres 1 vorverlegt. Dadurch beginnt der ' Kalender am Anfang eines 400-Jahres-Zyklus und die Rechnung ' vereinfacht sich. Als laufendes Jahr (LJ) wird die Anzahl Jahre ab ' diesem Startjahr bezeichnet. Für das Jahr 1 ist LJ=0, für das ' Jahr 2 ist LJ=1 usw. Das Julianische Datum dieses Tages ist ' JD0 = 1721426. LJ = J - 1 ' Zur Berechnung des Julianischen Datums wird die Anzahl der vollen ' 400-Jahres-Zyklen (N400) seit dem Startjahr, sowie die Anzahl der ' vollen Jahre (R400) im letzten, unvollständigen 400-Jahres-Zyklus ' berechnet: N400 = Int(LJ / 400) ' (ganzzahlig) R400 = LJ Mod 400 ' Aus R400 wird die Anzahl der vollen 100-Jahres-Zyklen (N100) des ' letzten 400-Jahres-Zyklus, sowie die Anzahl der vollen Jahre (R100) ' im letzten, unvollständigen 100-Jahres-Zyklus berechnet: N100 = Int(R400 / 100) ' (ganzzahlig) R100 = R400 Mod 100 ' Dann wird aus R100 die Anzahl der vollen 4-Jahres-Zyklen (N4) des ' letzten 100-Jahres-Zyklus, sowie die Anzahl der vollen Jahre (N1) ' im letzten, unvollständigen 4-Jahres-Zyklus berechnet: N4 = Int(R100 / 4) ' (ganzzahlig) N1 = R100 Mod 4 ' Das Julianische Datum berechnet sich dann zu: JD = JD0 + N400 * 146097 + N100 * 36524 + N4 * 1461 + N1 * 365 + LT ' Die Zahlen sind die Länge der Zyklen in Tagen. 1461 (3*365+366) für ' den 4-Jahres-Zyklus, 36524 (24*1461 + 1460) für den 100-Jahres-Zyklus ' und 146097 (3*36524 + 36525) für den 400-Jahres-Zyklus. Text1(1) = JD ' Bei einigen Werten von LT ergibt die Formel für M einen um 1 zu ' großen Wert. Das macht sich durch M=13 oder T<1 bemerkbar. In diesen ' Fällen müssen die Werte für M und T korrigiert werden ' falls (M>12) oder (T<1): vermindere M um 1 und berechne T erneut If M1 > 12 Or T1 < 1 Then lblGreg(1) = "M1 = " & M1 & " T1 = " & T1 M1 = M1 - 1 T1 = LT - 30 * (M1 - 1) - (SK + MK) End If lblGreg(0).Caption = "T = " & T & " M = " & M & _ " J = " & J & " SK = " & SK & _ " MK = " & MK & " LT = " & LT & _ " LJ = " & LJ & _ " N400 = " & N400 & " R400 = " & R400 & _ " N100 = " & N100 & _ " N4 = " & N4 & " N1 = " & N1 & _ " ( M = " & M1 & " T = " & T1 & " )" lblWT(1).Caption = Wochentag(Int((JD + 1.5)) Mod 7) lblWT(1).ToolTipText = Int((JD + 1.5)) Mod 7 Case 3 If IsNumeric(Text1(1)) = False Then MsgBox "Das Julianische Datum fehlt", vbExclamation, "Kalender" Exit Sub End If lblGreg(2).Caption = "" lblGreg(3).Caption = "" JD = Text1(1) JD0 = 1721426 ' Um ein Datum des Gregorianischen Kalenders bei gegebenem ' Julianischen Datum zu berechnen, werden zunächst die Anzahl der ' vollen 4-Jahres-Zyklen (N400) seit dem Startjahr und die Anzahl Tage ' (R400) des letzten, unvollständigen 400-Jahres-Zyklus berechnet: N400 = Int((JD - JD0) / 146097) ' (ganzzahlig) R400 = (JD - JD0) Mod 146097 ' Als nächstes wird die Anzahl der vollen 100-Jahres-Zyklen (N100) ' des unvollständigen 400-Jahres-Zyklus berechnet, sowie die Anzahl Tage ' (R100) des letzten, unvollständigen 100-Jahres-Zyklus: N100 = Int(R400 / 36524) ' (ganzzahlig) R100 = R400 Mod 36524 ' Am letzten Tag des Zyklus ergibt die Rechnung N100=4 und R100=0. ' In diesem Fall müssen die Werte korrigiert werden: If N100 = 4 Then ' Zwischenergebnis sichern lblGreg(3) = "N100 = " & N100 N100 = 3 And R100 = 36524 End If ' Dann wird die Anzahl der vollen 4-Jahres-Zyklen (N4) des unvollständigen ' 100-Jahres-Zyklus berechnet, sowie die Anzahl Tage (R4) des letzten, ' unvollständigen 4-Jahres-Zyklus: N4 = Int(R100 / 1461) ' (ganzzahlig) R4 = R100 Mod 1461 ' Schließlich wird die Anzahl der vollen Jahre (N1) des unvollständigen ' 4-Jahres-Zyklus berechnet, sowie der laufende Tag (LT) im letzten Jahr: N1 = Int(R4 / 365) ' (ganzzahlig) LT = R4 Mod 365 ' Am letzten Tag des Zyklus ergibt die Rechnung N1=4 und LT=0. ' In diesem Fall müssen die Werte korrigiert werden: If N1 = 4 Then ' Zwischenergebnis sichern lblGreg(3) = lblGreg(3) & " N1 = " & N1 N1 = 3 And LT = 365 End If ' Das laufende Jahr LJ ergibt sich zu: LJ = 400 * N400 + 100 * N100 + 4 * N4 + N1 ' Die Berechnung der Jahreszahl (J) aus LJ ergibt sich durch: J = LJ + 1 lblGreg(2).Caption = lblGreg(2).Caption & " LJ = " & LJ & " J = " & J ' Monat ermitteln bei gegebenem LT M = Int((LT + 1) / 30 + 1) ' (ganzzahlig) ' Monatskorrektur ermitteln MK = Monatskorrektur(M) ' Korrekturwert Schaltjahr ermitteln If IstSchaltjahrGreg(J) And M > 2 Then SK = 1 Else SK = 0 End If T = LT - 30 * (M - 1) - (SK + MK) If MK = "" Then MK = "?" ' Bei einigen Werten von LT ergibt die Formel für M einen um 1 zu ' großen Wert. Das macht sich durch M=13 oder T<1 bemerkbar. In diesen ' Fällen müssen die Werte für M und T korrigiert werden: ' falls (M>12) oder (T<1): vermindere M um 1 und berechne T erneut If M > 12 Or T < 1 Then lblGreg(3) = lblGreg(3) & " M = " & M & " T = " & T M = M - 1 ' Monatskorrektur ermitteln MK = Monatskorrektur(M) ' Korrekturwert Schaltjahr ermitteln If IstSchaltjahrGreg(J) And M > 2 Then SK = 1 Else SK = 0 End If T = LT - 30 * (M - 1) - (SK + MK) End If lblGreg(2).Caption = "N400 = " & N400 & " R400 = " & R400 & _ " N100 = " & N100 & " R100 = " & R100 & _ " N4 = " & N4 & " R4 = " & R4 & " N1 = " & N1 & _ " LT = " & LT & " LJ = " & LJ & " J = " & J & _ " MK = " & MK & " ( T = " & T & " M = " & M & ")" & _ " " & T & "." & M & "." & J End Select End Sub Function IstSchaltjahrGreg(ByVal Jahreszahl As Double) As Boolean IstSchaltjahrGreg = (Jahreszahl Mod 4 = 0 And _ (Jahreszahl Mod 100 <> 0 Or Jahreszahl Mod 400 = 0)) End Function Function IstSchaltjahrJul(ByVal Jahreszahl As Double) As Boolean If Jahreszahl < 0 Then ' Vorchristliche Jahre IstSchaltjahrJul = (Jahreszahl Mod -4 = -1) Else ' Nachchristliche Jahre IstSchaltjahrJul = (Jahreszahl Mod 4 = 0) End If End Function Private Function Monatskorrektur(ByVal M As Integer) As Integer ' Monatskorrektur ermitteln Select Case M Case 1, 4, 5 Monatskorrektur = -1 Case 2, 6, 7 Monatskorrektur = 0 Case 3 Monatskorrektur = -2 Case 8 Monatskorrektur = 1 Case 9, 10 Monatskorrektur = 2 Case 11, 12 Monatskorrektur = 3 End Select End Function Private Function Wochentag(ByVal n As Integer) As String ' Wochentag Select Case n Case 0 Wochentag = "Sonntag" Case 1 Wochentag = "Montag" Case 2 Wochentag = "Dienstag" Case 3 Wochentag = "Mittwoch" Case 4 Wochentag = "Donnerstag" Case 5 Wochentag = "Freitag" Case 6 Wochentag = "Samstag" End Select End Function Dieser Tipp wurde bereits 13.784 mal aufgerufen. Voriger Tipp | Zufälliger Tipp | Nächster Tipp
Anzeige
Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv Vol.6 (einschl. Beispielprojekt!) Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv! - nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten - Symbol-Galerie mit mehr als 3.200 Icons im modernen Look Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m. |
Neu! sevCommand 4.0 Professionelle Schaltflächen im modernen Design! Mit nur wenigen Mausklicks statten auch Sie Ihre Anwendungen ab sofort mit grafischen Schaltflächen im modernen Look & Feel aus (WinXP, Office, Vista oder auch Windows 8), inkl. große Symbolbibliothek. Tipp des Monats April 2024 Skyfloy Chart von Microsoft und dazu noch gratis Tutorial für Microsoft Chart Controls für Microsoft .NET Framework 3.5 Access-Tools Vol.1 Über 400 MByte Inhalt Mehr als 250 Access-Beispiele, 25 Add-Ins und ActiveX-Komponenten, 16 VB-Projekt inkl. Source, mehr als 320 Tipps & Tricks für Access und VB |
||||||||||||||||
Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein. |