Startseite / Tipps / VB 5/6-Tipp 0402: Rechnen mit Datum und Zeiten

VB 5/6-Tipp 0402: Rechnen mit Datum und Zeiten

 von R. Mueller

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Project1.vbp -------------
'--------- Anfang Modul "Module1" alias Module1.bas ---------


'Autor: R. Mueller
'E-Mail: r.mueller@sz-online.de

'VB bietet zum Darstellen des Datums den Datentyp "Date" an.
'Weniger bekannt ist das VB intern mit dem Datentyp "Double"
'(Kennzeichen: #) arbeitet und auch genauso speichert(8 Byte).

'Deshalb kann mann jederzeit einer Variablen mit dem Datentyp
'Double Datumswerte zuweisen und umgekehrt (Demo 1).

'Der Datentyp Variant ist hierzu nicht geeignet, weil er zu
'unerwarteten Ergebnissen führen kann. Der Datumswert ist eine
'fortlaufende Nummer für jeden Tag zwischen -657434.999999999
'(01.01.100 23:59:59) und 2958465.99999999 (31.12.9999 23:59:59)

'Der Wert hinter dem "." entspricht dem dezimalen Bruchteil
'eines Tages. (0.1 entspricht demnach 2 Stunden und 24 Minuten)

'Das Übertragen des Datumswertes in einen Datum String entspricht
'der Funktion: xDstr$ =Format$(xDwert#, "dd.mm.yyyy hh:mm:ss")

'Wird der Datumswert selbst in einem String zwischengespeichert
'(Str$(xDwert#)), so sollte dieser mindestens 22 Zeichen aufnehmen
'können.(Mal selber mit kleinen negativen Zeitdifferenzen testen.)

'Die direkte Bildausgabe des Datentypes Date ist mit einigen beab-
'sichtigten Fehlern ausgestattet, so zeigt er nicht 00:00:00 an
'um eine reine Datumsangabe zu ermöglichen.

'So wird das Datum 30.12.1899 nicht ausgegeben aber plötzlich
'00:00:00 angezeigt(Demo 2) und von 1930 bis 2029 wird das Jahr
'nur 2 stellig ausgegeben.(Demo 1)

'Das berechnen von Differenzen zwischen Tagen und Zeiten kann man
'direkt mit dem Datumswert durchführen (Demo 3).
'Mit xDwert# = TimeValue("22:01:15") kann man auch eine Zeitdauer
'in einen Datumwert umformen.

'Den Wochentag (und alle anderen Bestandteile des Datums) als
'String erhält man aus der Function "Format$(xDwert#,"dddd")
'(Demo 3). Näheres hierzu im Anhang!

'Eine Ausgabe von Datumteilen im Datentyp Long(&) erhält man mit
'den Funktionen:

'  xx& = Hour(xDwert#)     'Stunde 0-23
'  xx& = Minute(xDwert#)   'Minuten 0-59
'  xx& = Second(xDwert#)   'Sekunden 0-59
'  xx& = Year(xDwert#)     'Jahr 100 - 9999
'  xx& = Month((xDwert#)   'Monat 1-12
'  xx& = WeekDay(xDwert#)  'Wochentag
'  xx& = Day(xDwert#)      'Tag 1-31  (Demo 4)

'Die Mid$ und Val Function baucht man also hierzu nicht zu be-
'mühen. Auch hier kann wahlweise der Datum Wert(#) oder der
'Datentyp "Date" verwendet werden. VB bietet noch einige spe-
'zielle Funktionen für Datumsberechnunen die aber nur geeignet
'sind wenn man mit dem auf Ganze abgerundeten Wert zufrieden
'ist, dann sind diese sehr vielseitig zu verwenden.

'Man erhält die Anzahl der vollen Perioden(xPer&),(z.B."q" Quar-
'tale) innerhalb des Zeitraumes:
'  xx& = DateDiff(xPer$, xDwert#, xDwert2#)

'Addiert xn& Perioden(xPer&) zum Datum xDwert#:
'  xx& = DateAdd(xPer$, xn&, xDwert#)

'    xPer$ = "yyyy"  'Jahr
'    xPer$ = "q"     'Quartal
'    xPer$ = "m"     'Monat
'    xPer$ = "y"     'Tag des Jahres
'    xPer$ = "d"     'Tag
'    xPer$ = "w"     'Wochentag
'    xPer$ = "ww"    'Woche
'    xPer$ = "h"     'Stunde
'    xPer$ = "n"     'Minute
'    xPer$ = "s"     'Sekunde, s. Hilfe unter: "DateDiff"


'Beim Übergeben eines Datums(String) an den Datentyp "Date"
'kann DateValue bzw.TimeValue entfallen.
'
'Im Demo 5 demonstriere ich am Beispiel einer Arbeitszeitabrech-
'nung mit gleitender Arbeitszeit und wie man dies nutzen kann.

'Das Dreispaltige Array könnte Ein Listenfeld oder eine am besten
'Datenbanktabelle sein.
'  1.Spalte: Datum
'  2.Spalte: Uhrzeit Beginn der Arbeit
'  3.Spalte: Auftrag Nr.  bzw. CheckIn, Pause Oder CheckOut

'Auch der Bericht zu den Arbeitszeiten gehört besser in eine
'Datenbank.

'In Demo 6 zeige ich einen Weg Datumsangaben zu sortieren ohne
'eine Form oder Datenbank zu benutzen. Bei großen Datenmengen
'benutze ich ausschließlich eine Indexierte Datenbanktabelle.


'Übrigens das x vor den Variablen ziert alle Localen Variablen
'um sie von globalen zu unterscheiden. (Ich möchte mich in in
'Projekten mit Hunderten Variablen auch nach Jahren noch selber
'zurecht finden)

Option Explicit

Public Sub Main()
    Dim xInp As String
    Dim xDwert As Double
    Dim xDwert2 As Double
    Dim xDwertDiff As Double
    Dim xDwertDiff2 As Double
    Dim xDwertDiff3 As Double
    Dim xDwDatum As Double
    Dim xDwDatum2 As Double
    Dim xDate1 As Date
    Dim xDate2 As Date
    Dim xDstr As String
    Dim xAStr As String
    Dim xStunde As Double
    Dim xSekunde As Double
    Dim xA As Long
    Dim xB As Long
    Dim xI As Long
    
    Dim xWordIndex() As String

    xInp = InputBox("Bitte Nummer des Demos angeben (1-6)", "Demos")
    xInp = Trim$(xInp)
    
    Select Case xInp
        Case 1 'Demo 1
            xDate1 = Now
            xDwert = Now
            xDate2 = xDwert
            xDstr = xDate2
            xDstr = Format$(xDwert, "dd.mm.yyyy hh:mm:ss")
            
            MsgBox "Das heutige Datum: " & xDate1 & Chr$(13) _
                   & "Fortlaufende Nummer: " & xDwert & _
                   Chr$(13) & "Zurück in ein Datumstring " & _
                   xDstr$, vbOKOnly, "Demo 1"
            
        Case 2 'Demo 2
            xAStr = "30.12.1899"
            xDate1 = xAStr
            xDwert = xDate1
            xDstr = Format$(xDwert, "dd.mm.yyyy hh:mm:ss")
            
            MsgBox "Datum(String): " & xAStr & Chr$(13) & _
                   "VB: Date: " & xDate1 & Chr$(13) & _
                   "Fortlaufende Nummer: " & xDwert & _
                   Chr$(13) & "Zurück in ein Datumstring " _
                   & xDstr$, vbOKOnly, "Demo 2"
            
        Case 3 'Demo 3
            xDwert = Now
            
            '15 Tage und 25 Minuten später
            xDwert2 = xDwert + 15 + TimeValue("00:25:00")
            xDstr = Format$(xDwert2, "dd.mm.yyyy hh:mm:ss")
            xDwertDiff = DateDiff("h", xDwert, xDwert2)
            xStunde = TimeValue("01:00")
            xDwertDiff2 = (xDwert2 - xDwert) / xStunde
            xSekunde = TimeValue("00:00:01")
            xDwertDiff3 = (xDwert2 - xDwert) / xSekunde \ 1
            
            MsgBox "Datum in 15 Tagen und 25 Minuten: " & _
                   xDstr$ & Chr$(13) & "Wochentag in 15 " & _
                   "Tagen: " & Format$(xDwert2, "dddd") & _
                   Chr$(13) & "Differenz in Stunden: " & _
                   xDwertDiff & Chr$(13) & "Differenz(h)" & _
                   " aus Fortlaufender Nummer: " & _
                   xDwertDiff2 & Chr$(13) & "Differenz(sek)" _
                   & " aus Fortlaufender Nummer " & _
                   "(ganze Sekunden): " & xDwertDiff3, _
                   vbOKOnly, "Demo 1"
            
        Case 4 'Demo 4
            xDwert = Now
            xA = Year(xDwert)
            xDwert2 = DateAdd("ww", -4, xDwert)
            xDstr = Format$(xDwert2, "dd.mm.yyyy hh:mm:ss")
            
            'das Jahr wird durch das laufende Jahr ergänzt
            '(wenn nicht angegeben)
            xA = DateDiff("y", Now, "24.12")
            
            MsgBox "Sie Befinden sich im Jahre: " & Str$(xA) _
                   & " Nach Cristi" & Chr$(13) & "Wochentag" & _
                   " in 15 Tagen: " & Format$(xDwert2, _
                   "dddd") & Chr$(13) & "Welches Datum war" & _
                   " Heute vor 4 Wochen: " & xDstr & _
                   Chr$(13) & "In wieviel Tagen kommt der" & _
                   " Weihnachtsmann in diesem Jahr: " _
                   & xA & Chr$(13)
            
        Case 5 'Demo 5
            Dim xArray3(2, 10) As String
            
            'eine kürzere Länge kann zu Fehlern führen
            ReDim xBericht(1, 1) As String * 22
            Dim xCheckIn As Long
            
            xArray3(0, 0) = "24.12.2000"
            xArray3(1, 0) = "08:13"
            xArray3(2, 0) = "CheckIn"
            xArray3(1, 1) = "08:30"
            xArray3(2, 1) = "413"
            xArray3(1, 2) = "09:15"
            xArray3(2, 2) = "Pause"
            xArray3(1, 3) = "09:33"
            xArray3(2, 3) = "413"
            xArray3(1, 4) = "11:18"
            xArray3(2, 4) = "522"
            xArray3(1, 5) = "12:03"
            xArray3(2, 5) = "Pause"
            xArray3(1, 6) = "12:43"
            xArray3(2, 6) = "599"
            xArray3(1, 7) = "17:11"
            xArray3(2, 7) = "CheckOut"
            xArray3(1, 8) = "21:11"
            xArray3(2, 8) = "CheckIn"
            xArray3(1, 9) = "21:11"
            xArray3(2, 9) = "413"
            xArray3(0, 10) = "25.12.2000"
            xArray3(1, 10) = "01:23"
            xArray3(2, 10) = "CheckOut"
            xBericht(0, 0) = "ArbeitsZeit"
            xBericht(0, 1) = "Pause"
            
            For xI = 0 To UBound(xArray3, 2)
                If Len(Trim$(xArray3(0, xI))) > 0 Then
                    xDwDatum = DateValue(xArray3(0, xI))
                End If
                
                xDwDatum2 = xDwDatum
                
                If UBound(xArray3, 2) > xI Then
                    If Len(Trim$(xArray3(0, xI + 1))) > 0 Then
                        xDwDatum2 = DateValue(xArray3(0, xI + 1))
                   End If
                End If
                
                If UCase$(Trim(xArray3(2, xI))) = "CHECKIN" Then
                    xCheckIn = -1
                Else
                   If UCase(Trim(xArray3(2, xI))) = "CHECKOUT" Then
                        xCheckIn = 0
                   End If
                  
                   If xCheckIn Then
                        xDwert = xDwDatum + TimeValue(xArray3(1, xI))
                        xDwert2 = xDwDatum2 + TimeValue(xArray3(1, xI + 1))
                        xDwertDiff = xDwert2 - xDwert
                        xB = -1
                        
                        For xA = 0 To UBound(xBericht, 2)
                            If Trim(xBericht$(0, xA&)) = Trim(xArray3$(2, xI&)) Then
                            
                                xB = xA
                                Exit For
                            End If
                        Next xA
                        
                        If xB < 0 Then
                            xA = UBound(xBericht, 2)
                            xA = xA + 1
                            ReDim Preserve xBericht(1, xA)
                            xBericht(0, xA) = Trim(xArray3(2, xI))
                            
                            xBericht(1, xA) = Str$(xDwertDiff)
                        Else
                            xDwertDiff3 = Val(xBericht(1, xB))
                            xBericht(1, xB) = Str$(xDwertDiff3 + xDwertDiff)
                        End If
                        
                        If Not UCase(Trim(xArray3(2, xI))) = "PAUSE" Then
                            xDwertDiff3 = Val(xBericht(1, 0))
                            xBericht(1, 0) = Str$(xDwertDiff3 + xDwertDiff)
                        End If
                    End If
                End If
            Next xI
            
            xAStr = "Auftrag Nr:           Minuten: " & Chr$(13)
            For xI = 0 To UBound(xBericht, 2)
                xDwert = Val(xBericht(1, xI)) / TimeValue("00:01") \ 1
                xAStr = xAStr & xBericht(0, xI) & Str$(xDwert) & Chr$(13)
            Next xI
            
            MsgBox xAStr, vbOKOnly, " Bericht "
            
        Case 6 'Demo 6
            ReDim xArray(4) As String
            
            'array einlesen
            xArray$(0) = "31.12.2000 03:07:18"
            xArray$(1) = "01.01.1009"
            xArray$(2) = "01.01.1950 02:08"
            xArray$(3) = "31.12.1949"
            xArray$(4) = "31.12.2000"
            
            'Eintragen in Sortierarray in eimem Sortierbaren
            'Format (für Jahre von 1000 bis 9999)
            ReDim xWordArray$(0)
            For xI = 0 To UBound(xArray)
                xDate1 = xArray(xI)
                ReDim Preserve xWordArray(xI)
                
                'Jahr . Monat .Tag !!!!
                xWordArray(xI) = Format$(xDate1, "yyyy.mm.dd hh:mm:ss")
            Next xI&
            
            'Sortier Index erstellen
            ReDim xWordIndex(UBound(xWordArray) + 1)
            For xI = 0 To UBound(xWordArray) + 1
                xWordIndex(xI) = xI
            Next xI
            
            Call QuickSort(xWordArray(), xWordIndex, 0, UBound(xWordArray))
            
            'array ausgeben
            xAStr = "Formatiert:                   Original: " & Chr$(13)
            
            For xI = 0 To UBound(xWordArray)
                xDate1 = xArray(xWordIndex(xI))
                xAStr$ = xAStr & Format$(xDate1, _
                        "dd.mm.yyyy hh:mm:ss") & "    " & _
                        xArray(xWordIndex(xI)) & Chr$(13)
                
            Next xI
            
            MsgBox xAStr, vbOKOnly, " Zeiten Sortiert "
            
      Case Else
             ' ...
    End Select
End Sub

Private Sub QuickSort(xWordArray() As String, xWordIndex() As String, xLow As Long, xHigh As Long)
    'Dimensioniert man Dim WordArray$(0), Dim WordIndex&(0) als
    'globale Variable (Allgemein)(Deklaration), dann wird
    'QuickSort etwas schneller.
    
    Dim xRandIndex As Long
    Dim xPartition As String
    Dim xI As Long
    Dim xJ As Long
    Dim xTemp As Long
    
    If xLow < xHigh Then
        If xHigh - xLow = 1 Then
            If UCase$(xWordArray(xWordIndex(xLow))) > _
                UCase$(xWordArray(xWordIndex(xHigh))) Then
                
                xTemp = xLow
                xLow = xHigh
                xHigh = xTemp
            End If
        Else
            xRandIndex& = Int(Rnd * (xHigh - xLow + 1)) + xLow
            xTemp = xWordIndex(xHigh)
            xWordIndex(xHigh) = xWordIndex(xRandIndex)
            xWordIndex(xRandIndex) = xTemp
            xPartition = UCase$(xWordArray(xWordIndex(xHigh)))
            
            Do
                xI = xLow
                xJ = xHigh

                Do While (xI < xJ) And (UCase$(xWordArray(xWordIndex(xI))) _
                    <= xPartition)
                    
                    xI = xI + 1
                Loop
                
                Do While (xJ > xI) And (UCase$(xWordArray(xWordIndex(xJ))) _
                    >= xPartition)
                   
                    xJ = xJ - 1
                Loop
          
                If xI < xJ Then
                    xTemp = xWordIndex(xI)
                    xWordIndex(xI) = xWordIndex(xJ)
                    xWordIndex(xJ) = xTemp
                End If
            Loop While xI < xJ
            
            xTemp = xWordIndex(xI)
            xWordIndex(xI) = xWordIndex(xHigh)
            xWordIndex(xHigh) = xTemp
            
            If (xI - xLow) < (xHigh - xI) Then
                QuickSort xWordArray(), xWordIndex(), xLow, xI - 1
                QuickSort xWordArray(), xWordIndex(), xI + 1, xHigh
            Else
                QuickSort xWordArray(), xWordIndex(), xI + 1, xHigh
                QuickSort xWordArray(), xWordIndex(), xLow, xI - 1
            End If
        End If
    End If
End Sub
'---------- Ende Modul "Module1" alias Module1.bas ----------
'-------------- Ende Projektdatei Project1.vbp --------------

Tipp-Kompatibilität:

Windows/VB-Version	Win32s	Win95	Win98	WinME	WinNT4	Win2000	WinXP
VB4
VB5
VB6

Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version: VB6 VB5 VB4

Windows-Version: Windows XP Windows 2000 Windows NT4 Windows Me Windows 98 Windows 95 Win32s

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 10 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.

Private Function GetTimeInterval(ByVal nSeks As Long) As String
  Dim h As Long, m As Long
  Dim sInterv As String
 
  h = nSeks \ 3600
  nSeks = nSeks Mod 3600
  m = nSeks \ 60
  nSeks = nSeks Mod 60
 
  sInterv = Format(h, "00") & ":" & Format(m, "00") & ":" & Format(nSeks, "00")
 
  GetTimeInterval = sInterv

End Function

Zeit = GesamtTime = GetTimeInterval(Zeit1)