|
|
|
|
|
|
Sollten Sie sich bei der Überschrift dieses Artikels an "Rick's Coffee American" in Casablanca, Humphrey Bogart oder Ingrid Bergmann erinnert fühlen, so müssen wir Sie enttäuschen. Auch haben wir hier und heute kein Wave-File mit dem berühmten Ohrwurm. Vielmehr wollen wir uns einmal mit der Datumsdarstellung und -berechnung in Visual Basic beschäftigen.
Schon Albert Einstein erkannte, dass die Zeit nicht starr sondern relativ ist. Und da Naturgesetze nun mal auch für Computer gelten, haben verschiedenste Programmierer sich alle erdenkliche Mühe gegeben, um auch in diesem Bereich für Verwirrung zu sorgen. Ein einfaches Beispiel zeigt schon, wo es unter anderem lang geht. So sagt das Datum "23.12.2001 18:36:12" nichts über die Zeitzone aus. Es kann für manche Zeitgenossen die weihnachtliche Bescherung schon vorbei sein oder eben noch bevorstehen.
Dieses Manko der Datumsdarstellung kommt besonders dann zum Tragen, wenn Daten an einer zentralen Stelle gesammelt werden, aber aus verschiedenen Zeitzonen kommen. Sicherlich kann man Konfusionen dabei umgehen, indem man per Definition alle Daten beispielsweise auf Greenwich bezieht (GMT) und die entsprechenden Offsets berücksichtigt. Ein anderes Manko der Datumsdarstellung in Visual Basic ist die Tatsache, dass die kleinste Zeiteinheit die Sekunde ist, darunter läuft nichts mehr.
Ebenso ist es in VB nicht möglich, nur einen reinen Zeitwert darzustellen, da dieser immer zugleich einen Datumswert darstellt.
Es wäre also wünschenswert, ein Datumsformat zu bekommen, das zum einen ohne Zeitzonen auskommt, zum anderen auch die Darstellung von Zeiteinheiten kleiner als eine Sekunde zulässt und auch ein Arbeiten nur mit Zeiten zulässt. Beginnen wir mit der ersten Forderung: Es gibt ein Datumsformat ohne Zeitzonen. Dies ist das so genannte "Julianische Datum", das 1581 von Joseph Justus Scaliger in der Astronomie eingeführt wurde. Bei diesem Datum gibt es keine Jahre und Monate, sondern es werden die Tage seit dem 1.1.4713 v.Chr. gezählt.
Zusätzlich wird die Zeit dabei als Nachkommastelle (ähnlich wie in VB auch) dargestellt. Jedoch ist Mitternacht hier nicht als 0, sondern als 0,5 definiert - die Tage beginnen also Mittags.
Unsere hier vorgestellte Version des Julianischen Datums arbeitet nach diesem Prinzip, allerdings leicht abgewandelt und nicht mit Nachkommastellen. Auch liegt bei uns Mitternacht nicht auf dem Wert 0,5, wie im Original, sondern wie gewohnt auf 0. Bevor wir aber loslegen, wollen wir noch ein paar kleine, aber wichtige Vorüberlegungen anstellen.
Wie oben ausgeführt, werden die Tage seit dem 1.1.4713 v.Chr. gezählt. Damit kommen schon ganz beträchtliche Werte zusammen - Integer und Single scheiden als Datentyp aus. Blieben als Datentypen noch Double oder Decimal. Wir wollen wir aber auch eine Auflösung feiner als eine Sekunde bekommen. Wenn wir jetzt einmal den Millisekundenbereich anpeilen, so bekommen wir pro Tag 86.400.000 Millisekunden. Im Zusammenspiel mit den Tagen überfordern wir dann aber auch Double in der Auflösung, zumal dieser Datentyp auf Grund der Gleitkommadarstellung auch noch zu systemimmanenten Ungenauigkeiten neigt. Ebenso ist Decimal nicht recht geeignet. Zwar würden Wertebereich und Auflösungsgenauigkeit reichen, nur ist Decimal leider kein eigenständig deklarierbarer Datentyp, sondern nur ein Untertyp des Datentyps Variant, was nicht unbedingt zu einer typsicheren und performanten Programmierung beiträgt.
Am besten wären also zwei Long-Werte geeignet, einer für die Tage und einer für die Zeit. Leider lässt sich aber mit zwei Long-Werten, selbst wenn diese in einem benutzerdefinierten Datentyp (UDT) zusammen gefasst werden, nur schlecht arbeiten. Auch ist ein Vergleichen der Daten so nicht oder nur umständlich möglich, abgesehen davon, dass man den UDT zum Speichern in Datenbanken ebenfalls wieder umformen müsste. Dennoch hat die Verwendung von zwei Long-Werten seine unbestreitbaren Vorteile (was übrigens auch Microsoft beim Speichern der Datumswerte im SQL-Server erkannt hat - aber das ist ein anderes Thema...).
Als Lösung bietet sich hier der Datentyp Currency an. Dieser ist im Grunde nichts anderes, als ein skalierter Ganzzahl-Typ mit einer Breite von 8 Bytes, also eigentlich zwei Long-Werten. Wir werden diesen Datentyp zweckentfremden, indem wir in den oberen 4 Bytes den Long-Wert mit der Anzahl der Tage speichern und in den unteren 4 Bytes die Zeit (Sie sehen, der Spruch "Zeit ist Geld" hat sich wieder einmal bewahrheitet). Das hat den Vorteil, dass Vergleichs- und Sortiervorgänge in Visual Basic, in Datenbanken und in anderen Bibliotheken ohne Wissen um den eigentlichen Inhalt vorgenommen werden können, da die Daten rein nummerisch sind und in der richtigen Relation zueinander stehen.
Stellt sich nun die Frage, wie wir unsere beiden Long-Werte in den Datentyp Currency überführen können. Dazu bedienen wir uns der VB-Anweisung LSet, die es uns ermöglicht, Daten von einem UDT in den anderen zu schaufeln, ohne auf die Datentypen achten zu müssen (nur die Strukturgröße ist relevant). Wir definieren uns jetzt in einem Standardmodul zwei passende UDTs:
Public Type KonvLong
jdTime As Long 'Die Zeit des julianischen Datums
jdDays As Long 'Die Tage des julianischen Datums
End Type
Public Type KonvCurr
jdCompl As Currency 'Das gesamte julianische Datum
End Type
Nur können wir die Teilwerte zusammenfassen oder aufsplitten:
Dim pvUdtKCur As KonvCurr
Dim pvUdtKLng As KonvLong
LSet pvUdtKLng = pvUdtKCur 'Datum aufsplitten
LSet pvUdtKCur = pvUdtKLng 'Datum zusammenfassen
Kommen wir jetzt zur Berechnung des Julianischen Datums. Die beiden wesentlichen Funktionen (gregorianisches Datum zu julianischem und zurück) sind GetJulDays und GetGregDat.
GetJUlDays ermittelt aus den übergebenen Parametern die Anzahl der Tage nach einem Algorithmus von Fliegel und van Flandern. Warum aber so umständlich und nicht einfach die Anzahl der Tage mit DateDiff ermitteln? Zum einen würde der Wertebereich den zulässigen Bereich von DateDiff sprengen, zum anderen liefert DateDiff nicht immer korrekte Ergebnisse. Außerdem fehlen in unserem derzeit gültigem Kalender (dem sog. gregorianischen) die Tage vom 4.10. bis zum 15.10.1582 (der Grund hierfür war die Absicht, fehlende Schalttage auf einen Schlag auszugleichen). Wenn Sie die Tagesdifferenz aber mit DateDiff ermitteln, werden Ihnen brav 11 Tage Differenz angezeigt. GetJulDays liefert aber nur für ein gültiges gregorianisches Datum korrekte Werte, weshalb wir den Wertebereich für gregorianische Daten auf den Zeitraum vom 1.1.1583 bis zum 31.12.2199 eingeschränkt haben. Weiterhin ist der Wertebereich des julianischen Datum auf Werte größer Null beschränkt, um ein einfaches Vergleichen mittels "<", "=" und ">" zu ermöglichen.
Wenn diese Einschränkungen Sie stören, so müssen Sie die entsprechenden Berichtigungen und Prüfungen selbst einbauen. Natürlich können Sie den Bereich für das gregorianische Datum nach Belieben nach oben erweitern, in der Hoffnung, dass Microsoft die Berechnung der Schaltjahre usw. in den VB-eigenen Routinen korrekt implementiert hat. Dazu brauchen Sie nur im Hauptmodul der DLL den entsprechenden Wert der oberen Grenze neu zu setzen. Von einer Erweiterung nach unten raten wir Ihnen jedoch dringend ab, es sei denn, Sie kennen und berücksichtigen alle Besonderheiten der Datumswirren vor dem 15.10.1582 - anderenfalls werden Sie sich garantiert falsche Ergebnisse einhandeln. Der Bereich des unseres Julianischen Datums beginnt eben am 1.1.1583 und reicht bis zum 31.12.2199. - das sollte für die normale Büroanwendung allemal langen. Als Zeitwert kann ein Bereich von 00:00:00.000 bis 575:59:59.999 angegeben werden - das entspricht 23 Tagen, 23 Stunden, 59 Minuten, 59 Sekunden und 999 Millisekunden.
Die Umwandlung zurück, von der Anzahl der Tage zum gregorianischen Datum, übernimmt die zweite Kern-Funktion GetGregDat, die als Rückgabewert ein Datum vom Typ Date liefert.
Als Besonderheit können sie jetzt auch ganz einfach mit Zeiten rechnen. So können Sie entweder zwei Zeiten von einander abziehen oder diese addieren oder aber zu einem Datum eine Zeit hinzurechnen, die Sie beispielsweise aus einer Messung heraus gewonnen haben, ohne diese erst in eine Grundeinheit wie bei DateAdd umwandeln zu müssen. Sie können hier etwa zum Datum 25.12.2001 17:53:52 nun ganz einfach den Zeitwert 125:24:45.324 addieren.
Die einzelnen Funktionen des Moduls modJulDat.bas:
Die Funktionen IsJulDate prüft, ob ein gültiges Julianisches Datum vorliegt.
IsJulDateValid prüft, ob ein gültiges julianisches Datum oder eine gültige julianische Zeit vorliegt.
GetNowJulTime liefert Ihnen die aktuelle Zeit im julianischen Format. Da im Julianischen Datum keine Zeitzonen vorgesehen sind, haben wir auf die API-Funktion GetSystemTime zurückgegriffen, die das Datum auf GMT bezogen liefert. Die Auflösung beträgt dabei 1 Millisekunde.
GetNowJulDat liefert Ihnen das aktuelle Datum im julianischen Format. Auch hier haben wir wieder auf die API-Funktion GetSystemTime zurückgegriffen, die das Datum auf GMT bezogen liefert. Die Auflösung beträgt ebenfalls 1 Millisekunde.
Die Funktionen GetDays, GetHour, GetMinute, GetSecond und GetMilliSec liefern Ihnen aus einem julianischen Datum die Tage, Stunden, Minuten, Sekunden und Millisekunden in dem uns geläufigen Datenformat.
KonvToJulDat wandelt ein Datum vom Datentyp Date in ein Julianisches Datum um.
KonvToGregDat wandelt ein Datum (julianisch/Currency) in ein Datum des Datentyps Date um. Wenn Sie sich im erlaubten Datenbereich befinden, können Sie dann mit den VB-Datumsfunktionen den Wochentag und Ähnliches ermitteln.
MakeJulDat liefert ein julianisches Datum gemäß den eingegebenen Parametern. Die Auflösung beträgt wieder 1 Millisekunde.
MakeJulTime liefert eine julianische Zeit gemäß der eingegebenen Parameter. Die Auflösung beträgt ebenfalls 1 Millisekunde.
DateIntervall liefert ähnlich der Funktion VB-DateDiff die Anzahl eines bestimmten Intervalls zwischen zwei julianischen Daten. Da hier Wochen, Monate und Jahre irrelevant sind, sind diese Intervalle auch nicht implementiert.
JulDatCalc dient zum Addieren und Subtrahieren von zwei julianischen Daten bzw. Zeiten. Der größere der beiden Parameter sollte immer an erster Stelle stehen.
ShowLongTime gibt einen String zurück, in dem die Zeit des übergebenen julianischen Datums formatiert bis auf die Millisekunde genau dargestellt wird.
JulDateAdd ähnelt der VB-Funktion DateAdd: Zu einem Datum wird eine bestimmte Größe eines Intervalls hinzugezählt oder abgezogen.
Mit diesen Funktionen können Sie jetzt alle relevanten Operationen ausführen. Die Werte legen Sie einfach, wie im Beispielprojekt gezeigt, in einer Variablen vom Typ Currency ab.
Noch ein Wort zum Abschluss: Ihnen wird sicherlich die exzessive Nutzung von CDec in den Berechnungen auffallen. Dies ist notwendig, um die implizite Typumwandlung von Visual Basic auszuschalten, da hier meist ein großer und dabei exakt darzustellender Datenbereich benötigt wird.
Private Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
Private Type KonvLong
jdTime As Long
jdDays As Long
End Type
Private Type KonvCurr
jdCompl As Currency
End Type
Private Const Max_JulDat_Time As Long = 86399999
Private Const Max_JulTme_Hour As Long = 575
Private Const Min_VbDate As Date = #1/1/1583#
Private Const Max_VbDate As Date = #12/31/2199 11:59:59 PM#
Public Enum KsEnmJulDatType
KsNotValid = 0
KsJulDateTime = 1
KsJulTimeOnly = 2
End Enum
Public Enum KsEnmJulDatIntervall
KsDays = 1
KsHours = 2
KsMinutes = 3
KsSeconds = 4
KsMilliSec = 5
End Enum
Public Enum KsEnmJulDatCalc
KsAddDates = 1
KsSubDates = 2
End Enum
Public Enum KsEnmJulDatErrConst
TimeNotValid = 39100
DateNotValid = 39101
DateOutOfRange = 39102
NoJulDatPassed = 39103
ValueUnderRange = 39104
ValueOverRange = 39105
MillSecOutOfRange = 39106
HourOutOfRange = 39107
MinuteOutOfRange = 39108
SecondsOutOfRange = 39109
FirstDateNotValid = 39110
SecondDateNotValid = 39111
FirstParamNotValid = 39112
SecondParamNotValid = 39113
SubtractOutOfRange = 39114
DateNotToFigure = 39115
TimeOutOfRange = 39116
GetTimeError = 39200
GetDateError = 39201
End Enum
Private Declare Sub GetSystemTime Lib "kernel32" _
(lpSystemTime As SYSTEMTIME)
Dim pvUdtKLng As KonvLong
Dim pvUdtKCur As KonvCurr
Dim pvBooOk As Boolean
pvUdtKCur.jdCompl = JulDate
LSet pvUdtKLng = pvUdtKCur
pvBooOk = True
Select Case pvUdtKLng.jdTime
Case Is < 0
pvBooOk = False
Case Is > Max_JulDat_Time
pvBooOk = False
End Select
If pvBooOk Then
If pvUdtKLng.jdDays < 1 Then
pvBooOk = False
End If
End If
IsJulDate = pvBooOk
End Function
Public Function IsJulDateValid(ByVal JulDateTime As Currency) _
As KsEnmJulDatType
Dim pvUdtLong As KonvLong
Dim pvUdtCurr As KonvCurr
pvUdtCurr.jdCompl = JulDateTime
LSet pvUdtLong = pvUdtCurr
Select Case pvUdtLong.jdDays
Case Is < 0
IsJulDateValid = KsNotValid
Case 0
If pvUdtLong.jdTime < 0 Then
IsJulDateValid = KsNotValid
Else
IsJulDateValid = KsJulTimeOnly
End If
Case Is > 0
If pvUdtLong.jdTime < 0 Or _
pvUdtLong.jdTime > Max_JulDat_Time Then
IsJulDateValid = KsNotValid
Else
IsJulDateValid = KsJulDateTime
End If
End Select
End Function
Public Function GetNowJulTime() As Currency
Dim pvUdtSysTime As SYSTEMTIME
On Error GoTo ErrHdl_GetNowJulTime
GetSystemTime pvUdtSysTime
With pvUdtSysTime
GetNowJulTime = _
MakeJulTime(.wHour, .wMinute, .wSecond, .wMilliseconds)
End With
ErrHdl_GetNowJulTime:
If Err.Number > 0 Then
Err.Raise GetTimeError, "[GetNowJulTime] - KsDate", _
"Fehler beim ermitteln der aktuellen Zeit." & vbCrLf & _
"Wert ist ungültig!"
GetNowJulTime = -1
End If
End Function
Public Function GetNowJulDat() As Currency
Dim pvUdtSysTime As SYSTEMTIME
On Error GoTo ErrHdl_GetNowJulDat
GetSystemTime pvUdtSysTime
With pvUdtSysTime
GetNowJulDat = MakeJulDat(.wDay, .wMonth, .wYear, .wHour, _
.wMinute, .wSecond, .wMilliseconds)
End With
ErrHdl_GetNowJulDat:
If Err.Number > 0 Then
Err.Raise GetDateError, "[GetNowJulDat] - KsDate", _
"Fehler beim ermitteln des aktuellen Datums." & vbCrLf & _
"Wert ist ungültig!"
GetNowJulDat = -1
End If
End Function
Public Function GetDays(ByVal KsJulDat As Currency) As Integer
GetDays = GetJulSplit(KsJulDat).jdDays
End Function
Public Function GetHour(ByVal KsJulDat As Currency) As Integer
Dim pvLngTime As Long
pvLngTime = GetJulSplit(KsJulDat).jdTime
GetHour = pvLngTime \ 3600000
End Function
Public Function GetMinute(ByVal KsJulDat As Currency) As Integer
Dim pvLngTime As Long
pvLngTime = GetJulSplit(KsJulDat).jdTime
pvLngTime = pvLngTime \ 60000
GetMinute = pvLngTime - ((pvLngTime \ 60) * 60)
End Function
Public Function GetSecond(ByVal KsJulDat As Currency) As Integer
Dim pvLngTime As Long
pvLngTime = GetJulSplit(KsJulDat).jdTime
pvLngTime = pvLngTime \ 1000
GetSecond = pvLngTime - ((pvLngTime \ 60) * 60)
End Function
Public Function GetMilliSec(ByVal KsJulDat As Currency) As Integer
Dim pvLngTime As Long
pvLngTime = GetJulSplit(KsJulDat).jdTime
GetMilliSec = pvLngTime - ((pvLngTime \ 1000) * 1000)
End Function
Public Function KonvToJulDat(ByVal vbDateType As Date) As Currency
If vbDateType < Min_VbDate Or vbDateType > Max_VbDate Then
Err.Raise 39201, "KonvToJulDat [KsDate]", _
"Datum außerhalb des Gültigkeitsbereiches"
End If
KonvToJulDat = MakeJulDat(Day(vbDateType), Month(vbDateType), _
Year(vbDateType), Hour(vbDateType), Minute(vbDateType), _
Second(vbDateType))
End Function
Public Function KonvToGregDat(ByVal KsJulDat As Currency) As Date
Dim pvDteTmp As Date
If Not IsJulDate(KsJulDat) Then
Err.Raise NoJulDatPassed, "[KonvToGregDat - ksDate]", _
"Es wurde kein gültiges julilanisches Datum übergeben!"
End If
pvDteTmp = GetGregDat(GetJulSplit(KsJulDat).jdDays)
pvDteTmp = pvDteTmp + TimeSerial(GetHour(KsJulDat), _
GetMinute(KsJulDat), GetSecond(KsJulDat))
Select Case pvDteTmp
Case Is < Min_VbDate
Err.Raise ValueUnderRange, "[KonvToGregDat - ksDate]", _
"Das Ergebnis liefert ein Datum, " & _
"das vor dem Gültigkeitsbereich liegt"
Case Is > Max_VbDate
Err.Raise ValueOverRange, "[KonvToGregDat - ksDate]", _
"Das Ergebnis liefert ein Datum, " & _
"das nach dem Gültigkeitsbereich liegt"
Case Else
KonvToGregDat = pvDteTmp
End Select
End Function
Public Function MakeJulDat(ByVal Day As Integer, _
ByVal Month As Integer, _
ByVal Year As Integer, _
Optional ByVal Hour As Integer = 0, _
Optional ByVal Minute As Integer = 0, _
Optional ByVal Second As Integer = 0, _
Optional ByVal MilliSec As Integer = 0) As Currency
Dim pvUdtKLong As KonvLong
Dim pvUdtKCur As KonvCurr
Dim pvDteDateInp As String
Dim pvStrValInp As String
Const cRefFormat As String = "dd\.mm\.yyyy\ hh\:nn\:ss"
pvStrValInp = Format$(Day, "00\.") & Format$(Month, "00\.") & _
Format$(Year, "0000\ ") & Format$(Hour, "00\:") & _
Format$(Minute, "00\:") & Format$(Second, "00")
pvDteDateInp = DateSerial(Year, Month, Day) + _
TimeSerial(Hour, Minute, Second)
If Format$(pvDteDateInp, cRefFormat) <> pvStrValInp Then
Err.Raise 39202, "[MakeJulDat - ksDate]", _
"Der Datumswert ist ungültig"
Else
If MilliSec < 0 Or MilliSec > 999 Then
Err.Raise MillSecOutOfRange, "[MakeJulDat - ksDate]", _
"Millisekunden außerhalb des Gültigkeitsbereiches"
End If
End If
pvUdtKLong.jdDays = GetJulDays(Day, Month, Year)
pvUdtKLong.jdTime = (3600000 * CLng(Hour)) + (60000 * CLng(Minute)) _
+ (1000 * CLng(Second)) + MilliSec
LSet pvUdtKCur = pvUdtKLong
MakeJulDat = pvUdtKCur.jdCompl
End Function
Public Function MakeJulTime(Optional ByVal Hour As Integer = 0, _
Optional ByVal Minute As Integer = 0, _
Optional ByVal Second As Integer = 0, _
Optional ByVal MilliSec As Integer = 0) As Currency
Dim pvUdtKLong As KonvLong
Dim pvUdtKCur As KonvCurr
Select Case True
Case Hour < 0, Hour > Max_JulTme_Hour
Err.Raise HourOutOfRange, "[MakeJulTime - ksDate]", _
"Der Stundenwert überschreitet den Gültigkeitsbereich"
Case Minute < 0, Minute > 59
Err.Raise MinuteOutOfRange, "[MakeJulTime - ksDate]", _
"Der Minutenwert überschreitet den Gültigkeitsbereich"
Case Second < 0, Second > 59
Err.Raise SecondsOutOfRange, "[MakeJulTime - ksDate]", _
"Der Sekundenwert überschreitet den Gültigkeitsbereich"
Case MilliSec < 0, MilliSec > 999
Err.Raise MillSecOutOfRange, "[MakeJulTime - ksDate]", _
"Der Millisekunden überschreitet den Gültigkeitsbereich"
End Select
pvUdtKLong.jdDays = 0
pvUdtKLong.jdTime = (3600000 * CLng(Hour)) + (60000 * CLng(Minute)) _
+ (1000 * CLng(Second)) + MilliSec
LSet pvUdtKCur = pvUdtKLong
MakeJulTime = pvUdtKCur.jdCompl
End Function
Public Function DateIntervall(ByVal Intervall As KsEnmJulDatIntervall, _
ByVal JulDat1 As Currency, ByVal JulDat2 As Currency) As Variant
Dim pvVarDat1 As Variant
Dim pvVarDat2 As Variant
If Not IsJulDate(JulDat1) Then
Err.Raise FirstDateNotValid, "[DateInterval - ksDate]", _
"Das erste Datum ist ungültig!"
End If
If Not IsJulDate(JulDat2) Then
Err.Raise SecondDateNotValid, "[DateInterval - ksDate]", _
"Das zweite Datum ist ungültig!"
End If
Select Case Intervall
Case KsDays
pvVarDat1 = CDec(GetJulSplit(JulDat1).jdDays)
pvVarDat2 = CDec(GetJulSplit(JulDat2).jdDays)
Case KsHours
pvVarDat1 = CDec(CDec(GetJulSplit(JulDat1).jdDays) * 24) _
+ GetHour(JulDat1)
pvVarDat2 = CDec(CDec(GetJulSplit(JulDat2).jdDays) * 24) _
+ GetHour(JulDat2)
Case KsMinutes
pvVarDat1 = CDec(CDec(GetJulSplit(JulDat1).jdDays) * 1440) _
+ CDec(GetHour(JulDat1) * 60) + GetMinute(JulDat1)
pvVarDat2 = CDec(CDec(GetJulSplit(JulDat2).jdDays) * 1440) _
+ CDec(GetHour(JulDat2) * 60) + GetMinute(JulDat2)
Case KsSeconds
pvVarDat1 = CDec(CDec(CDec(GetJulSplit(JulDat1).jdDays)) _
* CDec(86400)) + CDec(CDec(GetHour(JulDat1)) * CDec(3600)) _
+ CDec(CDec(GetMinute(JulDat1)) * 60) + GetSecond(JulDat1)
pvVarDat2 = CDec(CDec(CDec(GetJulSplit(JulDat2).jdDays)) _
* CDec(86400)) + CDec(CDec(GetHour(JulDat2)) * CDec(3600)) _
+ CDec(CDec(GetMinute(JulDat2)) * 60) + GetSecond(JulDat2)
Case KsMilliSec
pvVarDat1 = CDec(CDec(GetJulSplit(JulDat1).jdDays) _
* CDec(86400000)) + CDec(CDec(GetHour(JulDat1)) _
* CDec(3600000)) + CDec(CDec(GetMinute(JulDat1)) _
* CDec(60000)) + CDec(CDec(GetSecond(JulDat1)) _
* CDec(1000)) + CDec(GetMilliSec(JulDat1))
pvVarDat2 = CDec(CDec(GetJulSplit(JulDat2).jdDays) _
* CDec(86400000)) + CDec(CDec(GetHour(JulDat2)) _
* CDec(3600000)) + CDec(CDec(GetMinute(JulDat2)) _
* CDec(60000)) + CDec(CDec(GetSecond(JulDat2)) _
* CDec(1000)) + CDec(GetMilliSec(JulDat2))
End Select
DateIntervall = CDec(pvVarDat2 - pvVarDat1)
End Function
Public Function JulDatCalc(ByVal Modus As KsEnmJulDatCalc, _
ByVal JulDteTme1 As Currency, ByVal JulDteTme2 As Currency) _
As Currency
Dim pvLngDays As Long
Dim pvLngTimes As Long
Dim pvJulTmp1 As Currency
Dim pvJulTmp2 As Currency
Select Case IsJulDateValid(JulDteTme1)
Case KsNotValid
Err.Raise FirstParamNotValid, "[JulDatCalc - ksDate]", _
"Der erste Parameter ist ungültig!"
Case KsJulDateTime
pvJulTmp1 = JulDteTme1
Case KsJulTimeOnly
pvLngTimes = GetJulSplit(JulDteTme1).jdTime
If pvLngTimes > Max_JulDat_Time Then
pvLngDays = Fix(pvLngTimes / (Max_JulDat_Time + 1))
pvLngTimes = _
CLng(pvLngTimes - (pvLngDays * (Max_JulDat_Time + 1)))
pvJulTmp1 = GetCurrencyDate(pvLngDays, pvLngTimes)
Else
pvJulTmp1 = JulDteTme1
End If
End Select
Select Case IsJulDateValid(JulDteTme2)
Case KsNotValid
Err.Raise SecondParamNotValid, "[JulDatCalc - ksDate]", _
"Der zweite Parameter ist ungültig!"
Case KsJulDateTime
pvJulTmp2 = JulDteTme2
Case KsJulTimeOnly
pvLngTimes = GetJulSplit(JulDteTme2).jdTime
If pvLngTimes > Max_JulDat_Time Then
pvLngDays = Fix(pvLngTimes / (Max_JulDat_Time + 1))
pvLngTimes = _
CLng(pvLngTimes - (pvLngDays * (Max_JulDat_Time + 1)))
pvJulTmp2 = GetCurrencyDate(pvLngDays, pvLngTimes)
Else
pvJulTmp2 = JulDteTme2
End If
End Select
Select Case Modus
Case KsAddDates
pvLngDays = GetJulSplit(pvJulTmp1).jdDays _
+ GetJulSplit(pvJulTmp2).jdDays
pvLngTimes = GetJulSplit(pvJulTmp1).jdTime _
+ GetJulSplit(pvJulTmp2).jdTime
If pvLngTimes > Max_JulDat_Time Then
pvLngDays = pvLngDays + 1
pvLngTimes = pvLngTimes - (Max_JulDat_Time + 1)
End If
Case KsSubDates
pvLngDays = GetJulSplit(pvJulTmp1).jdDays _
- GetJulSplit(pvJulTmp2).jdDays
Select Case IsJulDateValid(JulDteTme1)
Case KsJulDateTime
If pvLngDays < 1 Then
Err.Raise SubtractOutOfRange, "[JulDatCalc - ksDate]", _
"Subtraktion unterschreitet den Wertebereich!"
End If
Case KsJulTimeOnly
If pvLngDays < 0 Then
Err.Raise SubtractOutOfRange, "[JulDatCalc - ksDate]", _
"Subtraktion unterschreitet den Wertebereich!"
End If
End Select
pvLngTimes = GetJulSplit(pvJulTmp1).jdTime _
- GetJulSplit(pvJulTmp2).jdTime
If pvLngTimes < 0 Then
pvLngDays = pvLngDays - 1
pvLngTimes = Max_JulDat_Time + pvLngTimes
End If
End Select
JulDatCalc = GetCurrencyDate(pvLngDays, pvLngTimes)
End Function
Public Function ShowLongTime(ByVal JulDat As Currency) As String
Dim pvStrTmp As String
If Not IsJulDate(JulDat) Then
Err.Raise DateNotToFigure, "[ShowLongTime - ksDate]", _
"Das Datum ist ungültig und kann nicht dargestellt werden!"
End If
ShowLongTime = Format$(GetHour(JulDat), "00\:") _
& Format$(GetMinute(JulDat), "00\:") _
& Format$(GetSecond(JulDat), "00\.") _
& Format$(GetMilliSec(JulDat), "000")
End Function
Public Function JulDateAdd(ByVal Intervall As KsEnmJulDatIntervall, _
ByVal JulDat As Currency, ByVal Value As Long) As Currency
Dim pvLngDays As Long
Dim pvLngTime As Long
Dim pvLngDaysJD As Long
Dim pvLngTimeJD As Long
Dim pvLngFaktor As Long
Dim pvLngFaktor2 As Long
Dim pvVarTmp As Variant
If Not IsJulDate(JulDat) Then
Err.Raise DateNotValid, "[JulDateAdd - ksDate]", _
"Das Datum ist ungültig!"
End If
pvLngDaysJD = GetJulSplit(JulDat).jdDays
pvLngTimeJD = GetJulSplit(JulDat).jdTime
Select Case Intervall
Case KsDays
pvLngDays = Abs(Value)
pvLngTime = 0
Case KsHours
pvLngDays = Abs(Value) \ 24
pvLngTime = CLng((CDec(Abs(Value)) * CDec(3600000)) _
- CDec(pvLngDays) * CDec(Max_JulDat_Time + 1))
Case KsMinutes
pvLngDays = Abs(Value) \ 1440
pvLngTime = CLng((CDec(Abs(Value)) * CDec(60000)) _
- CDec(pvLngDays) * CDec(Max_JulDat_Time + 1))
Case KsSeconds
pvLngDays = Abs(Value) \ 86400
pvLngTime = CLng((CDec(Abs(Value)) * CDec(1000)) _
- CDec(pvLngDays) * CDec(Max_JulDat_Time + 1))
Case KsMilliSec
pvLngDays = Abs(Value) \ 86400000
pvLngTime = CLng(CDec(Abs(Value)) - CDec(pvLngDays) _
* CDec(Max_JulDat_Time + 1))
End Select
If Value >= 0 Then
pvLngDays = pvLngDaysJD + pvLngDays
pvLngTime = pvLngTimeJD + pvLngTime
If pvLngTime > Max_JulDat_Time Then
pvLngDays = pvLngDays + 1
pvLngTime = pvLngTime - (Max_JulDat_Time + 1)
End If
Else
pvLngDays = pvLngDaysJD - pvLngDays
If pvLngDays < 1 Then
Err.Raise SubtractOutOfRange, "[JulDatCalc - ksDate]", _
"Subtraktion unterschreitet den Wertebereich!"
End If
pvLngTime = pvLngTimeJD - pvLngTime
If pvLngTime < 0 Then
pvLngDays = pvLngDays - 1
pvLngTime = Max_JulDat_Time + pvLngTime
End If
End If
JulDateAdd = GetCurrencyDate(pvLngDays, pvLngTime)
End Function
Private Function GetCurrencyDate(ByVal jdDays As Long, _
ByVal jdTime As Long) As Currency
Dim pvUdtKLng As KonvLong
Dim pvUdtKCur As KonvCurr
Select Case jdTime
Case Is < 0
Err.Raise TimeOutOfRange, "GetCurrencyDate", _
"Zeit liegt außerhalb des Wertebereichs (<00:00:00:000)"
Case Is > Max_JulDat_Time
Err.Raise TimeOutOfRange, "GetCurrencyDate", _
"Zeit liegt außerhalb des Wertebereichs (>23:59:59:999)"
Case Else
pvUdtKLng.jdTime = jdTime
End Select
If jdDays < 0 Then
Err.Raise DateOutOfRange, "GetCurrencyDate", _
"Tagesdatum außerhalb des Wertebereichs!"
Else
pvUdtKLng.jdDays = jdDays
End If
LSet pvUdtKCur = pvUdtKLng
GetCurrencyDate = pvUdtKCur.jdCompl
End Function
Private Function GetJulSplit(ByVal JulDat As Currency) As KonvLong
Dim pvUdtKCur As KonvCurr
Dim pvUdtKLng As KonvLong
pvUdtKCur.jdCompl = JulDat
LSet pvUdtKLng = pvUdtKCur
GetJulSplit = pvUdtKLng
End Function
Private Function GetJulDays(ByVal intDay As Integer, _
ByVal intMonth As Integer, ByVal intYear As Integer) As Long
Dim lngDay As Long
Dim lngMonth As Long
Dim lngYear As Long
Dim varJulDat As Variant
Dim varD As Variant
Dim varA As Variant
Const curGREG As Currency = 588829
If intYear < 0 Then
lngYear = CLng(intYear) + 1
Else
lngYear = CLng(intYear)
End If
If intMonth > 2 Then
lngMonth = CLng(intMonth + 1)
Else
lngYear = lngYear - 1
lngMonth = CLng(intMonth + 13)
End If
lngDay = CLng(intDay)
varJulDat = CDec(CDec(Int(1461 * CDec(lngYear) / 4)) + CDec(Int(153 _
* CDec(lngMonth) / 5)) + CDec(lngDay) + 1720995)
varD = CDec(CDec(lngDay) + 31 * CDec(CDec(lngMonth) + 12 _
* CDec(lngYear)))
If varD >= CDec(curGREG) Then
varA = CDec(Int(CDec(lngYear) / 100))
varJulDat = varJulDat + (CDec(2 - varA + CDec(Int(varA / 4))))
End If
GetJulDays = varJulDat
End Function
Private Function GetGregDat(ByVal lngJulDat As Long) As Date
Dim varDay As Variant
Dim varMonth As Variant
Dim varYear As Variant
Dim varJulDat As Variant
Dim varA As Variant
Dim varB As Variant
Dim varC As Variant
Dim varD As Variant
Dim varE As Variant
Dim varALPHA As Variant
Const curGREG As Currency = 2299161
varJulDat = CDec(lngJulDat) + 1
If varJulDat < CDec(curGREG) Then
varA = CDec(varJulDat)
Else
varALPHA = CDec(Int(CDec(varJulDat - 1867216.25) / 36524.25))
varA = CDec(varJulDat + 1 + varALPHA - CDec(Int(varALPHA / 4)))
End If
varB = CDec(varA + 1524)
varC = CDec(Int(CDec(varB - 122.1) / 365.25))
varD = CDec(Int(CDec(1461 * varC) / 4))
varE = CDec(Int(CDec(varB - varD) / 30.6001))
varDay = CDec(Int(CDec(varB - varD) - _
CDec(Int(30.6001 * varE)) - 1))
If varE < CDec(13.5) Then
varMonth = CDec(varE - 1)
Else
varMonth = CDec(varE - 13)
End If
If varMonth > CDec(2.5) Then
varYear = CDec(varC - 4716)
Else
varYear = CDec(varC - 4715)
End If
GetGregDat = DateSerial(Int(varYear), Int(varMonth), Int(varDay))
End Function
|
|
|