ABOUT Visual Basic Programmieren Programmierung Download Downloads Tips & Tricks Tipps & Tricks Know-How Praxis VB VBA Visual Basic for Applications VBS VBScript Scripting Windows ActiveX COM OLE API ComputerPC Microsoft Office Microsoft Office 97 Office 2000 Access Word Winword Excel Outlook Addins ASP Active Server Pages COMAddIns ActiveX-Controls OCX UserControl UserDocument Komponenten DLL EXE
Diese Seite wurde zuletzt aktualisiert am 24.01.2002

Diese Seite wurde zuletzt aktualisiert am 24.01.2002
Aktuell im ABOUT Visual Basic-MagazinGrundlagenwissen und TechnologienKnow How, Tipps und Tricks rund um Visual BasicActiveX-Komponenten, Controls, Klassen und mehr...AddIns für die Visual Basic-IDE und die VBA-IDEVBA-Programmierung in MS-Office und anderen AnwendungenScripting-Praxis für den Windows Scripting Host und das Scripting-ControlTools, Komponenten und Dienstleistungen des MarktesRessourcen für Programmierer (Bücher, Job-Börse)Dies&Das...

Themen und Stichwörter im ABOUT Visual Basic-Magazin
Code, Beispiele, Komponenten, Tools im Überblick, Shareware, Freeware
Ihre Service-Seite, Termine, Job-Börse
Melden Sie sich an, um in den vollen Genuss des ABOUT Visual Basic-Magazins zu kommen!
Informationen zum ABOUT Visual Basic-Magazin, Kontakt und Impressum

Zurück...

As Time Goes By

Zurück...


Anzeige

Gerrit Kuhlendahl mailto:GerritKulendahl_juldat@aboutvb.de

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

Test-Projket und Modul modJulDat (juldat.zip - ca. 10 KB)


Artikel
Zum Download-Bereich dieses Artikel
Mail an den Autor dieses Artikels

KnowHow
Zur KnowHow-Übersicht

KnowHow-Themen
Themen - Allgemeines
Themen - Entwicklungsumgebung (VB-IDE)
Themen - Forms
Themen - Steuerelemente (Controls)
Themen - Grafik
Themen - Dateien
Themen - UserControls
Themen - Einsteiger-Tipps
Themen - Wussten Sie...?

Übersicht nach Titeln in alphabetischer Reihenfolge
Übersicht nach Erscheinungsdatum

Schnellsuche




Zum Seitenanfang

Copyright © 1999 - 2017 Harald M. Genauck, ip-pro gmbh  /  Impressum

Zum Seitenanfang

Zurück...

Zurück...

Download Internet Explorer