Die Klasse hat einige spezielle Attribute. Sie muss darum über den Modulbrowser→Import importiert werden, damit die Attribute aktiv sind.

datetime.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "DateTime"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'-------------------------------------------------------------------------------
'File         : DateTime.cls
'               Copyright mpl by ERB software
'               All rights reserved
'               http://wiki.yaslaw.info/dokuwiki/doku.php/vba/
'Environment  : VBA 2007+
'Version      : 1.10.0
'Name         : DetTime
'Author       : Stefan Erb (ERS)
'History      : 06.08.2014 - ERS - Creation
'               ...
'               29.03.2016 - ERS - sqlTimestamp/sqlDate und sqlTime Properties hinzugefügt. iByRef Standart in die Konstante C_DEFAULT_BYREF ausgelagert
'               21.06.2016 - ERS - Add Interface IFormattable
'               28.06.2016 - ERS - Kleine Fehler beim SQL-Formatumstellung behoben
'               04.07.2016 - ERS - Interfcae IFormattable und toString() um Parameters erweitert
'-------------------------------------------------------------------------------
Option Explicit
 
'-------------------------------------------------------------------------------
' -- ! SETTINGS !
'-------------------------------------------------------------------------------
'In Excel funktionieren Events nicht. Auch der NZ() gibt es dort nicht.
'Darum hier angeben ob es sich um MS Access handelt oder eben nicht. Leider gibts datzu keine Systemvariable
#Const isAccess = True
 
'Das Interface IFormattable ist in diesem Projekt vorhanden
#Const IFormattable_exists = True
 
'-------------------------------------------------------------------------------
' -- Interfaces
'-------------------------------------------------------------------------------
'/**
' * Das Interface IFormattable
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/classes/iformattable
' */
#If IFormattable_exists Then
    Implements IFormattable
#End If
 
'-------------------------------------------------------------------------------
' -- Public Members
'-------------------------------------------------------------------------------
 
'/**
' * Zusätzliche Parameters zu strToDate
' */
Public Enum dtParams
    dtNone = 0
    'Parameters zur Behandlung des InputStrings
    'dtInFormatIgnoreCase = 2 ^ 0        'Gross-Kleinschreibung bei Trennzeichen ignorieren
    dtInFormatFormat2 = 2 ^ 1           'Beim Übergabewert iFormat handelt sich um ein Format im Stil von {$DD}.{$MM}
    'Paramter zur SQL-Ausgabe
    dtOutSqlFormatUs = 2 ^ 5            'SQL Format US
    dtOutSqlFormatIso8601 = 2 ^ 6       'SQL Format EU (ISO8601)
    dtOutSqlFormatManual = 2 ^ 7        'Das Format wird vom User vorgegeben (muss über SqlDateFormatString oder über setParameter(dtpSqlDateFormatString, ...) gesetzt werden)
    'Rückgabetype (ist noch nicht durchgehend umgesetzt!)
'    dtOutDateTime = 2 ^ 15               'Als Returntyp ein DateTime
'    dtOutTimestamp = 2 ^ 16              'Ein Timestamp
End Enum
 
'/**
' * Paramter um das SQL-Format zu setzen. Es sind alle auch in dtParams vorhanden.
' */
Public Enum dtSqlFormats
    dtsqlus = dtOutSqlFormatUs              'US: #MM/DD/YYYY#
    dtSqlIso8601 = dtOutSqlFormatIso8601    'EU, ISO-Norm: #YYYY-MM-DD#     https://de.wikipedia.org/wiki/ISO_8601
    dtSqlManual = dtOutSqlFormatManual      'User Spezialformat
    dtSqlDefault = dtsqlus                  'Standard definieren
End Enum
 
'/**
' * Bei gewissen Methoden kann man das Rückgabetype auswählen
' */
Public Enum dtReturnTypes
    dtDateTime = 2 ^ 15     'dtOutDateTime
    dtTimestamp = 2 ^ 16    'dtOutTimestamp
    dtRetDefault = dtDateTime
End Enum
 
'/**
' * mögliche Errors. Normalerweise programmiere ich dazu Public Const. Das geht aber in eine Class nicht.
' */
Public Enum dtErrorNumbers
    dtErrInvalidFormat = vbObjectError + 1      'Der String passt nicht mit dem Format überein
    dtErrNotParseble = vbObjectError + 2        'Das Format ist nicht parsbar
End Enum
 
'/**
' * Attribute, die gesetzt werden können. Wird für setProperty genutzt
' */
Public Enum dtProperties
    dtpTimestamp
    dtpDateValue
    dtpTimeValue
    dtpYear
    dtpMonth
    dtpDay
    dtpHour
    dtpMinute
    dtpSecond
    dtpNanoSecond
    dtpMicroSecond
    dtpMilliSecond
    dtpFirstWeekOfYear
    dtpFirstDayOfWeek
    dtpPatternDelemiter
    dtpDayOfWeek
    dtpQuarter
    dtpWeek
    dtpDayOfYear
    dtpSqlTimeStamp
    dtpSqlDate
    dtpSqlTime
    dtpSqlFormat
    dtpReturnType
    dtpSqlDateFormatString
    dtpSqlDateTimeFormatString
    dtpSqlTimeFormatString
End Enum
'-------------------------------------------------------------------------------
' -- Private Members
'-------------------------------------------------------------------------------
Private Const C_DEFAULT_PATTERN_DELEMITER = "@"         'Fakultatives Patterntrennzeichen für strToDate
 
Private Const C_DEFAULT_BYREF As Boolean = True         'Einstellung, ob standardmässig dieRückgabeobjekte eine Refernez zum Original sind oder ein Clone
 
Private Const C_SQL_DATE_US_FORMAT = "\#MM\/DD\/YYYY\#"     'US Datumsformat
Private Const C_SQL_DATE_ISO8601_FORMAT = "\#YYYY-MM-DD\#"  'Europa ISO8601 Format
 
Private Const C_SQL_DATETIME_US_FORMAT = "\#MM\/DD\/YYYY HH:NN:SS\#"
Private Const C_SQL_DATETIME_ISO8601_FORMAT = "\#YYYY-MM-DD HH:NN:SS\#"
 
Private Const C_SQL_TIME_US_FORMAT = "\#HH:NN:SS\#"
Private Const C_SQL_TIME_ISO8601_FORMAT = "\#HH:NN:SS\#"
 
Private pTimeStamp                  As Date                 'Der allumfassende Timestamp
Private pNanoSecond                 As Variant              'Die Nachkommastellen in Nanosekunden
Private pFirstDayOfWeek             As VbDayOfWeek          'Erster Wochentag der Woche
Private pFirstWeekOfYear            As VbFirstWeekOfYear    'Definition der ersten Kalenderwoche
Private pPatternDelemiter           As String               'Delemiter bei unklaren Formaten beim einlesen
Private pSqlFormat                  As dtSqlFormats         'SQL-Format
Private pReturnTypes                As dtReturnTypes        'Rückgabeart
Private pSqlDateFormatString        As String
Private pSqlDateTimeFormatString    As String
Private pSqlTimeFormatString        As String
Private pParams                     As dtParams
 
'/**
' * Wird in der Funktion strToDate() verwendet um die einzelnen Abschnitte zuzuordnen
' */
Private Enum enuDatePartType
    dptYear = 2 ^ 0
    dptMonth = 2 ^ 1
    dptDay = 2 ^ 2
    dptHour = 2 ^ 3
    dptMinute = 2 ^ 4
    dptSecound = 2 ^ 5
    dptAmPm = 2 ^ 6
    dptNanosecond = 2 ^ 7
End Enum
 
'/**
' * Verschiedene Parser (analog zu strToDate())
' */
Private Enum tdParser
    pcDay = 2 ^ 0
    pcMonth = 2 ^ 2
    pcYear = 2 ^ 3
    pcHour = 2 ^ 4
    pcMinute = 2 ^ 5
    pcSecound = 2 ^ 6
    pcAmPm = 2 ^ 7
    pcDayOfYear = 2 ^ 8
    pcDayOfWeek = 2 ^ 9
    pcWeekOfYear = 2 ^ 10
    pcNonosecound = 2 ^ 11
    pcQuarterEnd = 2 ^ 12
    pcQuarter = 2 ^ 13
    pcDate = pcDay + pcMonth + pcYear + pcDayOfYear + pcDayOfWeek + pcWeekOfYear + pcQuarter + pcQuarterEnd
    pcTime = pcHour + pcMinute + pcSecound + pcAmPm + pcNonosecound
End Enum
 
'-------------------------------------------------------------------------------
' -- Public Constructors
'-------------------------------------------------------------------------------
 
'/**
' * Erstellt eine neue Insatance
' * Besitzt das Attribute instance.VB_UserMemId = 0. Darum ist dies die Standardfunktion für DateTime()
' * @param  Date/String/DateTime    Timestamp. Ein Datum, ein Datumsstring oder ein DateTime Objekt. Standart ist Now()
' * @param  String                  Wenn der TimeStampein String ist, kann hier das Format mitgegeben werden. Siehe auch http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/strtodate
' * @param  dtDtringParams          Weitere Parameters zum Stringformat
' * @param  vbDayOfWeek             Erster Tag der Woche
' * @param  vbFirstWeekOfYear       Definition der ersten Kalenderwoche im Kalender
' * @return DateTime
' */
Public Function instance( _
    Optional ByRef iTimestamp As Variant = Null, _
    Optional ByVal iFormat As String = Empty, _
    Optional ByVal iparams As dtParams = dtNone, _
    Optional ByVal iFirstDayOfWeek As VbDayOfWeek = vbUseSystemDayOfWeek, _
    Optional ByVal iFirstWeekOfYear As VbFirstWeekOfYear = vbUseSystem _
) As DateTime
Attribute instance.VB_UserMemId = 0
'Attribute instance.VB_UserMemId = 0
 
    Set instance = New DateTime: instance.construct iTimestamp, iFormat, iparams, iFirstDayOfWeek, iFirstWeekOfYear
End Function
 
'/**
' * Initialisiert das Objekt
' * @param  Date/String/DateTime    Timestamp. Ein Datum, ein Datumsstring oder ein DateTime Objekt, ein DateInterval oder ein DateInterval String. Standart ist Now()
' * @param  String                  Wenn der TimeStamp ein String ist, kann hier das Format mitgegeben werden. Siehe auch http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/strtodate
' * @param  dtDtringParams          Weitere Parameters zum Stringformat
' * @param  vbDayOfWeek             Erster Tag der Woche
' * @param  vbFirstWeekOfYear       Definition der ersten Kalenderwoche im Kalender
' * @return DateTime
' */
Public Function construct( _
    Optional ByRef iTimestamp As Variant = Null, _
    Optional ByVal iFormat As String = Empty, _
    Optional ByVal iparams As dtParams = dtNone, _
    Optional ByVal iFirstDayOfWeek As VbDayOfWeek = vbUseSystemDayOfWeek, _
    Optional ByVal iFirstWeekOfYear As VbFirstWeekOfYear = vbUseSystem _
) As DateTime
    'Paramters übernehmen
    pParams = iparams
    sqlFormat = iparams
    returnType = iparams
    firstDayOfWeek = iFirstDayOfWeek
    firstWeekOfYear = iFirstWeekOfYear
    'iTimestamp parsen
    Dim fd As Date: Select Case TypeName(iTimestamp)
        Case "DateTime":        pTimeStamp = iTimestamp.timestamp
        Case "DateInterval":    pTimeStamp = iTimestamp.addTo().timestamp
        Case "Date":            pTimeStamp = iTimestamp
        Case "String":
            'Ein In-Format ist definiert -> strToDate
            If iFormat <> Empty Then
                pTimeStamp = strToDate(CStr(iTimestamp), iFormat, iparams, iFirstDayOfWeek, iFirstWeekOfYear, pNanoSecond)
            'Es handelt sich um ein IntervalSpec
            ElseIf DateInterval.testIntervalString(CStr(iTimestamp)) Then
                pTimeStamp = DateInterval(iTimestamp).addTo().timestamp
            'Ein Datumsformatstring mit # begrenzt
            ElseIf iTimestamp Like "[#]*[#]" Then
                pTimeStamp = Eval(iTimestamp)
            Else
                'Die Nanosekunden extrahieren
                If rxExtractNanoSec.test(iTimestamp) Then
                    With rxExtractNanoSec.execute(iTimestamp)(0).subMatches
                        iTimestamp = .item(0)                   'Das Datum extrahieren
                        pNanoSecond = 10 ^ 9 * CDbl(.item(1))   'NanoSec bestimmen
                    End With
                End If
                'Timestamp parsen
                pTimeStamp = VBA.dateValue(iTimestamp) + VBA.timeValue(iTimestamp)
            End If
        Case "Null":        pTimeStamp = Now
        Case Else:
            'Die Numerischen Werte habe ich extra hier, ansonsten müsste ich alle Numerischen Tpen aufzählen
            If IsNumeric(iTimestamp) Then
                pTimeStamp = CDate(iTimestamp)
            Else
                Err.Raise 13, "DateTime.construct"
            End If
    End Select
    Set construct = Me
End Function
 
'/**
' * Setzt Datum und Zeit. Entspricht DateSerial() + TimeSreial() + Nanosekunden
' * @param  ...                     Die einzelnen Teile
' * @param  Booelan                 Angabe ob der Rückgabewert eine neue Instanz oder eine Referenz sein soll
' * @param  vbDayOfWeek             Erster Tag der Woche
' * @param  vbFirstWeekOfYear       Definition der ersten Kalenderwoche im Kalender
' * @return DateTime
' */
Public Function serial( _
        Optional ByVal iYear As Variant = Null, _
        Optional ByVal iMonth As Integer = 1, _
        Optional ByVal iDay As Integer = 1, _
        Optional ByVal iHour As Integer = 0, _
        Optional ByVal iMinute As Integer = 0, _
        Optional ByVal iSecond As Integer = 0, _
        Optional ByVal iNanoSecond As Variant = 0, _
        Optional ByVal iByRef As Boolean = C_DEFAULT_BYREF, _
        Optional ByVal iFirstDayOfWeek As VbDayOfWeek = vbUseSystemDayOfWeek, _
        Optional ByVal iFirstWeekOfYear As VbFirstWeekOfYear = vbUseSystem _
) As DateTime
    pFirstDayOfWeek = iFirstDayOfWeek
    pFirstWeekOfYear = iFirstWeekOfYear
    Dim ts As Date: ts = Empty
    If Not IsNull(iYear) Then ts = DateSerial(iYear, iMonth, iDay)
    If iHour + iMinute + iSecond > 0 Then ts = ts + TimeSerial(iHour, iMinute, iSecond)
 
    Set serial = retDt(ts, iNanoSecond, iByRef)
End Function
 
'-------------------------------------------------------------------------------
' -- Public Methodes
'-------------------------------------------------------------------------------
 
'/**
' * Klont das Objekt
' * @return DateTime
' */
Public Function clone() As DateTime
    Set clone = retDt(timestamp, nanoSecond, False)
End Function
 
'/**
' * Rechnet ein DateInterval zum Datum hinzu und gibt ein neues DateTime zurück.
' * @param  DateInterval/IntervalSpec/Days
' * @param  Boolean                             true: Das DateTimeObjekt wird selber verändert - False: Das Objekt selber wird nicht verändert
' * @return DateTime
' */
Public Function add(ByRef iInterval As Variant, Optional ByVal iByRef As Boolean = C_DEFAULT_BYREF) As DateTime
    Set add = addInterval(iInterval, 1, iByRef)
End Function
 
'/**
' * Rechnet ein einzelnen Part hinzu
' * @param  String      Interval-String gem. DateAdd().  Y, M, D, H, N, S, F, Q, W, WW
' * @param  Variant     Wert
' * @param  Boolean                             true: Das DateTimeObjekt wird selber verändert - False: Das Objekt selber wird nicht verändert
' * @return DateTime
' */
Public Function addSingleValue(ByVal iInterval As String, ByVal iNumber As Variant, Optional ByVal iByRef As Boolean = C_DEFAULT_BYREF) As DateTime
    Select Case UCase(iInterval)
        Case "Y", "M", "D", "H", "N", "S", "W", "WW", "Q":
            Set addSingleValue = retDt(DateAdd(iInterval, iNumber, pTimeStamp), 0, iByRef)
        Case "F":
            Dim nano As Variant: nano = pNanoSecond + iNumber
            Dim diffSec As Variant
            If nano > 999999999 Then
                diffSec = Fix(nano / 10 ^ 9)
                nano = nano - diffSec * 10 ^ 9
            ElseIf nano < 0 Then
                diffSec = Fix(nano / 10 ^ 9) - 1
                nano = Abs(diffSec * 10 ^ 9 - nano)
            End If
            Set addSingleValue = retDt(DateAdd("S", diffSec, pTimeStamp), nano, iByRef)
    End Select
End Function
 
'/**
' * Zählt ein DateInterval vom Datum ab und gibt ein neues DateTime zurück.
' * @param  DateInterval/IntervalSpec/Days
' * @param  Boolean                             true: Das DateTimeObjekt wird selber nicht verändert - False: Das Objekt selber wird verändert
' * @return DateTime
' */
Public Function minus(ByRef iInterval As Variant, Optional ByVal iByRef As Boolean = C_DEFAULT_BYREF) As DateTime
    Set minus = addInterval(iInterval, -1, iByRef)
End Function
'/**
' * Gibt die Differenz als DateInterval zu einem Datum zurück
' * @param  Date/String/DateTime
' * @param  Boolean
' * @return DateInterval
' */
Public Function diff( _
    Optional ByRef iTimestamp As Variant = Null, _
    Optional ByVal iAbsolute As Boolean = False _
) As DateInterval
    Set diff = DateInterval.instanceFromDateDiff(Me, iTimestamp, iAbsolute)
End Function
 
'/**
' * Gibt ein formatiertes Datum zurück -> VBA.format()
' * Pattern gemäss VBA-format plus Nanosekunden (F). Die Anzahl F gibt die Nachkommastellen der Sekunden an.
' * @param  String  Format
' * @param  vbDayOfWeek             Erster Tag der Woche
' * @param  vbFirstWeekOfYear       Definition der ersten Kalenderwoche im Kalender
' */
Public Function format( _
        ByVal iFormat As String, _
        Optional ByVal iFirstDayOfWeek As VbDayOfWeek = -1, _
        Optional ByVal iFirstWeekOfYear As VbFirstWeekOfYear = -1 _
) As String
    Dim firstDayOfWeek As VbDayOfWeek:          firstDayOfWeek = IIf(iFirstDayOfWeek = -1, pFirstDayOfWeek, iFirstDayOfWeek)
    Dim firstWeekOfYear As VbFirstWeekOfYear:   firstWeekOfYear = IIf(iFirstWeekOfYear = -1, pFirstWeekOfYear, iFirstWeekOfYear)
    Dim ns  As Double:                          ns = pNanoSecond / 10 ^ 9
    Dim correctedTimeStamp As Date:             correctedTimeStamp = pTimeStamp
    Dim pattern As String:                      pattern = iFormat
 
    If rxNS.test(pattern) Then
        Dim m As Object: For Each m In rxNS.execute(pattern)
            pattern = substrReplace(pattern, VBA.format(10 ^ m.length * ns, String(m.length, "0")), m.firstIndex, m.length)
        Next m
    ElseIf CInt(ns) = 1 Then
        'Microsekunden vorhanden, MS nicht im Format und grösser als 0.5 Sekunden -> Sekunden aufrunden
        correctedTimeStamp = DateAdd("S", 1, correctedTimeStamp)
    End If
    format = VBA.format(correctedTimeStamp, pattern, firstDayOfWeek, firstWeekOfYear)
End Function
 
'/**
' * Gibt ein formatiertes Datum zurück. Im gegensatz zu format() müssend ie Pattern in {$...} geschtrieben werden
' * @param  String  Format
' * @param  vbDayOfWeek             Erster Tag der Woche
' * @param  vbFirstWeekOfYear       Definition der ersten Kalenderwoche im Kalender
' */
Public Function format2( _
        ByVal iFormat As String, _
        Optional ByVal iFirstDayOfWeek As VbDayOfWeek = -1, _
        Optional ByVal iFirstWeekOfYear As VbFirstWeekOfYear = -1 _
) As String
    Dim firstDayOfWeek As VbDayOfWeek:          firstDayOfWeek = IIf(iFirstDayOfWeek = -1, pFirstDayOfWeek, iFirstDayOfWeek)
    Dim firstWeekOfYear As VbFirstWeekOfYear:   firstWeekOfYear = IIf(iFirstWeekOfYear = -1, pFirstWeekOfYear, iFirstWeekOfYear)
    Dim correctedTimeStamp As Date:             correctedTimeStamp = pTimeStamp
    Dim pattern As String
    Dim ns  As Double:                          ns = pNanoSecond / 10 ^ 9
 
    format2 = iFormat
 
    If CInt(ns) = 1 And Not rxNS2.test(format2) Then
        'Microsekunden vorhanden, MS nicht im Format und grösser als 0.5 Sekunden -> Sekunden aufrunden
        correctedTimeStamp = DateAdd("S", 1, correctedTimeStamp)
    End If
 
    'Microsekunden ausgeben
    Do While rxNS2.test(format2)
        Dim sm As Object: Set sm = rxNS2.execute(format2)(0).subMatches
        pattern = VBA.format(10 ^ Len(sm(2)) * ns, String(Len(sm(2)), "0"))
        If Len(sm(1)) + Len(sm(4)) > 0 Then pattern = sm(0) & pattern & sm(3)
        format2 = rxNS2.Replace(format2, pattern)
    Loop
 
    Do While rxFormats2.test(format2)
        pattern = rxFormats2.execute(format2)(0).subMatches(0)
        format2 = rxFormats2.Replace(format2, VBA.format(correctedTimeStamp, pattern, firstDayOfWeek, firstWeekOfYear))
    Loop
End Function
 
'/**
' * Schneidet Den Hinteren Teil des Timestamps ab
' * @example    DateTime(#2014-04-05 13:34:14#).trunc("H")  --> 05.04.2014 13:00:00
'               DateTime(#2014-04-05 13:34:14#).trunc("M")  --> 01.04.2014 00:00:00
' * @param  String      Interval-String gem. DateAdd().  YYYY, M, D, H, N, S
' * @param  Boolean     true: Das DateTimeObjekt wird selber verändert - False: Das Objekt selber wird nicht verändert
' * @return DateTime
' */
Public Function trunc( _
        Optional ByVal iInterval As String = "D", _
        Optional ByVal iByRef As Boolean = C_DEFAULT_BYREF _
) As DateTime
    Set trunc = retDt(truncTimestamp(iInterval), 0, iByRef)
End Function
 
'/**
' * Rundet den Timestamp
' * @example    DateTime(#2014-04-05 13:15:56#).round("H")  --> 05.04.2014 13:00:00
'               DateTime(#2014-04-05 13:34:14#).round("H")  --> 05.04.2014 14:00:00
' * @param  String      Interval-String gem. DateAdd().  YYYY, M, D, H, N, S
' * @param  Boolean     true: Das DateTimeObjekt wird selber verändert - False: Das Objekt selber wird nicht verändert
' * @return DateTime
' */
Public Function round( _
        Optional ByVal iInterval As String = "D", _
        Optional ByVal iByRef As Boolean = C_DEFAULT_BYREF _
) As DateTime
    Dim ts As Date: ts = timestamp
    Dim delta As Integer
    Select Case UCase(iInterval)
        Case "YYYY", "YY", "Y": delta = CInt(VBA.month(ts) / 12)
        Case "M", "MM":         delta = CInt(VBA.day(ts) / VBA.day(DateSerial(VBA.year(ts), VBA.month(ts) + 1, 0)))
        Case "D", "DD":         delta = CInt(VBA.hour(ts) / 24)
        Case "H", "HH":         delta = CInt(VBA.minute(ts) / 60)
        Case "N", "NN":         delta = CInt(VBA.second(ts) / 60)
        Case "S", "SS":         delta = CInt(pNanoSecond / 10 ^ 9)
        Case "W", "WW":         delta = CInt(VBA.format(ts, "w", pFirstDayOfWeek) / 7)
        Case Else:      Err.Raise 13, "DateTime.round"
    End Select
    Set round = retDt(truncTimestamp(iInterval, delta), 0, iByRef)
End Function
 
'/**
' * Erstellt ein Array mit einem Interval. Als erstes Datum wird der aktuelle DateTime verwendet
' * @param  DateInterval/IntervalSpec/Days
' * @param  Long/DateTime/Timestamp         Anzahl Einträge oder ein Endzeitpunkt
' * @param  dtReturnTypes                   Rückgabeformat: timestamp oder DateTime
' * @return Array<timestamp/DateTime>
' */
Public Function interval(ByRef iIntervalSpec As Variant, ByRef iSizeOrEnd As Variant, Optional ByVal iReturnType As dtReturnTypes = dtTimestamp) As Variant()
    Dim di As DateInterval:     Set di = DateInterval(iIntervalSpec)
    Dim argIsSize As Boolean:   argIsSize = IsNumeric(iSizeOrEnd)
    Dim dt As DateTime:         Set dt = Me.clone
    Dim endTs As Date:          If Not argIsSize Then endTs = DateTime(iSizeOrEnd).timestamp
    Dim size As Long:           If argIsSize Then size = CLng(iSizeOrEnd)
    Dim retArr() As Variant
    Dim i As Long
    Do While IIf(argIsSize, i < size, dt.timestamp <= endTs)
        ReDim Preserve retArr(i)
        'Datum in Array übernehmen
        refDt retArr(i), iReturnType, dt, False
        i = i + 1
        'Datum vorrücken
        dt.add di, True
    Loop
    interval = retArr
End Function
 
'/**
' * Ersetzt einen einzelnen Teil des Datums und gibt ein DateTime zurück
' * @param  String      Interval-String gem. DateAdd().  YYYY, M, D, H, N, S, F
' * @param  Long        Neuer Wert
' * @param  Boolean     true: Das DateTimeObjekt wird selber verändert - False: Das Objekt selber wird nicht verändert
' * @return DateTime
' */
Public Function modify( _
    ByVal iInterval As String, _
    ByVal iNumber As Long, _
    Optional ByVal iByRef As Boolean = C_DEFAULT_BYREF _
) As DateTime
    With Me.clone
        Select Case UCase(iInterval)
            Case "YYYY", "YY":      .year = iNumber
            Case "M", "MM":         .month = iNumber
            Case "D", "DD":         .day = iNumber
            Case "H", "HH":         .hour = iNumber
            Case "N", "NN":         .minute = iNumber
            Case "S", "SS":         .second = iNumber
            Case "F":               .nanoSecond = iNumber
            Case "W":               .dayOfWeek = iNumber
            Case "WW":              .week = iNumber
            Case "Y":               .dayOfYear = iNumber
            Case Else:      Err.Raise 13, "DateTime.modify"
        End Select
        Set modify = retDt(.timestamp, .nanoSecond, iByRef)
    End With
End Function
 
'/**
' * Gibt ein DateTime nur mit dem Datum zurück
' * @param  Boolean     true: Das DateTimeObjekt wird selber verändert - False: Das Objekt selber wird nicht verändert
' * @return DateTime
' */
Public Function getDateObj(Optional ByVal iByRef As Boolean = C_DEFAULT_BYREF) As DateTime
    Set getDateObj = retDt(dateValue, 0, iByRef)
End Function
 
'/**
' * Gibt ein DateTime nur mit der Uhrzeit zurück (ohne Nanosekunden)
' * @param  Boolean     true: Das DateTimeObjekt wird selber verändert - False: Das Objekt selber wird nicht verändert
' * @return DateTime
' */
Public Function getTimeObj(Optional ByVal iByRef As Boolean = C_DEFAULT_BYREF) As DateTime
    Set getTimeObj = retDt(timeValue, 0, iByRef)
End Function
 
'/**
' * Gibt ein DateTime mit dem ersten Tag des Monates zurück. Analog zu trunc("D")
' * @param  Boolean     true: Das DateTimeObjekt wird selber verändert - False: Das Objekt selber wird nicht verändert
' * @return DateTime
' */
Public Function getFirstDayOfMonth(Optional ByVal iByRef As Boolean = C_DEFAULT_BYREF) As DateTime
    Set getFirstDayOfMonth = retDt(truncTimestamp("M"), 0, iByRef)
End Function
 
'/**
' * Gibt ein DateTime mit dem letzten Tag des Monates zurück
' * @param  Boolean     true: Das DateTimeObjekt wird selber verändert - False: Das Objekt selber wird nicht verändert
' * @return DateTime
' */
Public Function getLastDayOfMonth(Optional ByVal iByRef As Boolean = C_DEFAULT_BYREF) As DateTime
    Set getLastDayOfMonth = retDt(DateSerial(year, month + 1, 0), 0, iByRef)
End Function
 
'/**
' * Gibt ein DateTime mit dem ersten Tag der Woche zurück. Analog zu trunc("WW")
' * @param  Boolean     true: Das DateTimeObjekt wird selber verändert - False: Das Objekt selber wird nicht verändert
' * @return DateTime
' */
Public Function getFirstOfWeek(Optional ByVal iByRef As Boolean = C_DEFAULT_BYREF) As DateTime
    Set getFirstOfWeek = retDt(truncTimestamp("W"), 0, iByRef)
End Function
 
'/**
' * Gibt ein DateTime mit dem letzten Tag der Woche zurück
' * @param  Boolean     true: Das DateTimeObjekt wird selber verändert - False: Das Objekt selber wird nicht verändert
' * @return DateTime
' */
Public Function getLastDayOfWeek(Optional ByVal iByRef As Boolean = C_DEFAULT_BYREF) As DateTime
    Set getLastDayOfWeek = retDt(truncTimestamp("W") + 6, 0, iByRef)
End Function
 
'-------------------------------------------------------------------------------
' -- Public Properties
'-------------------------------------------------------------------------------
 
'/**
' * Setzt ein Property ung gibt ein DateTime zurück
' * @param  dtProperties    Info, welches Property gesetzt werden soll
' * @param  Variant         Wert
' * @param  Boolean         true: Das DateTimeObjekt wird selber verändert - False: Das Objekt selber wird nicht verändert
' * @return DateTime
' */
Public Function setProperty( _
        ByVal iProperty As dtProperties, _
        ByVal iValue As Variant, _
        Optional ByVal iByRef As Boolean = C_DEFAULT_BYREF _
) As DateTime
    Set setProperty = retDt(Me.timestamp, Me.nanoSecond, iByRef)
    Select Case iProperty
        Case dtpTimestamp:                  setProperty.timestamp = iValue
        Case dtpDateValue:                  setProperty.dateValue = iValue
        Case dtpTimeValue:                  setProperty.timeValue = iValue
        Case dtpYear:                       setProperty.year = iValue
        Case dtpMonth:                      setProperty.month = iValue
        Case dtpDay:                        setProperty.day = iValue
        Case dtpHour:                       setProperty.hour = iValue
        Case dtpMinute:                     setProperty.minute = iValue
        Case dtpSecond:                     setProperty.second = iValue
        Case dtpNanoSecond:                 setProperty.nanoSecond = iValue
        Case dtpMicroSecond:                setProperty.microSecond = iValue
        Case dtpMilliSecond:                setProperty.milliSecond = iValue
        Case dtpFirstWeekOfYear:            setProperty.firstWeekOfYear = iValue
        Case dtpFirstDayOfWeek:             setProperty.firstDayOfWeek = iValue
        Case dtpPatternDelemiter:           setProperty.patternDelemiter = iValue
        Case dtpDayOfWeek:                  setProperty.dayOfWeek = iValue
        Case dtpQuarter:                    setProperty.quarter = iValue
        Case dtpWeek:                       setProperty.week = iValue
        Case dtpDayOfYear:                  setProperty.dayOfYear = iValue
        Case dtpSqlTimeStamp:               setProperty.sqlTimeStamp = iValue
        Case dtpSqlDate:                    setProperty.sqlDate = iValue
        Case dtpSqlTime:                    setProperty.sqlTime = iValue
        Case dtpSqlFormat:                  setProperty.sqlFormat = iValue
        Case dtpReturnType:                 setProperty.returnType = iValue
        Case dtpSqlDateFormatString:        sqlDateFormatString = iValue
        Case dtpSqlDateTimeFormatString:    sqlDateTimeFormatString = iValue
        Case dtpSqlTimeFormatString:        sqlTimeFormatString = iValue
    End Select
End Function
 
' Ganzes Datum inkl. Zeit (rundung mit Nanosekunden)
Public Property Get timestamp() As Date:
    timestamp = IIf(CInt(pNanoSecond / 10 ^ 9) = 1, DateAdd("S", 1, pTimeStamp), pTimeStamp)
End Property
Public Property Let timestamp(ByVal its As Date):       pTimeStamp = its:                               End Property
' Nur Datum
Public Property Get dateValue() As Variant:             dateValue = VBA.dateValue(timestamp):           End Property
Public Property Let dateValue(ByVal its As Variant):    pTimeStamp = VBA.dateValue(getDate(its)):       End Property
'Nur Zeit
Public Property Get timeValue() As Variant:             timeValue = VBA.timeValue(timestamp):           End Property
Public Property Let timeValue(ByRef its As Variant):    pTimeStamp = VBA.timeValue(getDate(its)):       End Property
'Year
Public Property Get year() As Integer:                  year = VBA.year(timestamp):                     End Property
Public Property Let year(ByVal iYear As Integer):       replaceOnePart dptYear, iYear:                  End Property
'Month
Public Property Get month() As Integer:                 month = VBA.month(timestamp):                   End Property
Public Property Let month(ByVal iMonth As Integer):     replaceOnePart dptMonth, iMonth:                End Property
Public Property Get monthName() As String:              monthName = Me.format("MMMM"):                  End Property
'Day
Public Property Get day() As Integer:                   day = VBA.day(timestamp):                       End Property
Public Property Let day(ByVal iDay As Integer):         replaceOnePart dptDay, iDay:                    End Property
'Hour
Public Property Get hour() As Integer:                  hour = VBA.hour(timestamp):                     End Property
Public Property Let hour(ByVal iHour As Integer):       replaceOnePart dptHour, iHour:                  End Property
'Minute
Public Property Get minute() As Integer:                minute = VBA.minute(timestamp):                 End Property
Public Property Let minute(ByVal iMinute As Integer):   replaceOnePart dptMinute, iMinute:              End Property
'Second
Public Property Get second() As Integer:                second = VBA.second(timestamp):                 End Property
Public Property Let second(ByVal iSecond As Integer):   replaceOnePart dptSecound, iSecond:             End Property
'Nanosekunden: 10^-9  Vorsicht: Enthält auch Makro- und Millisekunden
Public Property Get nanoSecond() As Variant:            nanoSecond = pNanoSecond:                       End Property
Public Property Let nanoSecond(ByVal iNS As Variant):   pNanoSecond = iNS:                              End Property
'Mikrosekunden. 10^-6  Vorsicht: Enthält auch Millisekunden
Public Property Get microSecond() As Long:              microSecond = CLng(pNanoSecond / 10 ^ 3):       End Property
Public Property Let microSecond(ByVal iMS As Long):     pNanoSecond = iMS * 10 ^ 3:                     End Property
'Millisekunden. 10^-3
Public Property Get milliSecond() As Long:              milliSecond = CLng(pNanoSecond / 10 ^ 6):       End Property
Public Property Let milliSecond(ByVal iMS As Long):     pNanoSecond = iMS * 10 ^ 6:                     End Property
'Definition der ersten Kalenderwoche im Kalender
Public Property Get firstWeekOfYear() As VbFirstWeekOfYear: firstWeekOfYear = pFirstWeekOfYear:         End Property
Public Property Let firstWeekOfYear(ByVal ifW As VbFirstWeekOfYear): pFirstWeekOfYear = ifW:            End Property
'Erster Tag der Woche
Public Property Get firstDayOfWeek() As VbDayOfWeek:    firstDayOfWeek = pFirstDayOfWeek:               End Property
Public Property Let firstDayOfWeek(ByVal ifDW As VbDayOfWeek):    pFirstDayOfWeek = ifDW:               End Property
'Patterndemeliter. Default @
Public Property Get patternDelemiter() As String:        patternDelemiter = pPatternDelemiter:          End Property
Public Property Let patternDelemiter(ByVal iDelim As String): pPatternDelemiter = iDelim:               End Property
'DayOfWeek
Public Property Get dayOfWeek() As Integer
    dayOfWeek = CInt(VBA.format(timestamp, "W", firstDayOfWeek, firstWeekOfYear))
End Property
Public Property Let dayOfWeek(ByVal iDayOfWeek As Integer)
    'Für die Differnez wird extra nicht dayOfWeek genommen, sondern der Wochentag unabhängig von
    'den Einstellungen ermittelt, damit ein Wert aus dem Enum vbDayOfWeek zurückgegeben wird
    'Me.add (iDayOfWeek - dayOfWeek), True
    Me.add (iDayOfWeek - CInt(VBA.format(timestamp, "W"))), True
End Property
'Quarter
Public Property Get quarter() As Integer:               quarter = CInt(VBA.format(timestamp, "Q")):     End Property
Public Property Let quarter(ByVal iQuarter As Integer)
    Me.addSingleValue "Q", iQuarter - Me.quarter
End Property
'Week
Public Property Get week() As Integer
    week = getISOWeekNum(timestamp, firstDayOfWeek)
End Property
Public Property Let week(ByVal iWeek As Integer)
    Me.addSingleValue "WW", iWeek - Me.week
End Property
 
Public Property Get weekYear() As Integer
 
End Property
 
'DayOfWeekName
Public Property Get dayOfWeekName() As String:
    dayOfWeekName = Me.format("DDDD")
End Property
'DayOfYear
Public Property Get dayOfYear() As Long
    dayOfYear = CLng(VBA.format(pTimeStamp, "y", pFirstDayOfWeek, pFirstWeekOfYear))
End Property
Public Property Let dayOfYear(ByVal iDays As Long)
    trunc("YY").add iDays - 1
End Property
 
'Timestamp im SQL-Format
Public Property Get sqlTimeStamp() As String
    sqlTimeStamp = Me.format(sqlDateTimeFormatString)
End Property
Public Property Let sqlTimeStamp(ByVal iSqlString As String)
    pTimeStamp = Eval(iSqlString)
End Property
 
'Date im SQL-Format
Public Property Get sqlDate() As String
    sqlDate = Me.format(sqlDateFormatString)
End Property
Public Property Let sqlDate(ByVal iSqlString As String)
    pTimeStamp = Eval(iSqlString)
End Property
 
'Timest im SQL-Format
Public Property Get sqlTime() As String
    sqlTime = Me.format(sqlTimeFormatString)
End Property
Public Property Let sqlTime(ByVal iSqlString As String)
    pTimeStamp = Eval(iSqlString)
End Property
 
'-------------------------------------------------------------------------------
' -- Weitere Properties
'-------------------------------------------------------------------------------
 
'Definition des SQL-Formates
Public Property Get sqlFormat() As dtSqlFormats
    sqlFormat = pSqlFormat
End Property
Public Property Let sqlFormat(ByVal iSqlFormat As dtSqlFormats)
    pSqlFormat = Switch(andB(iSqlFormat, dtSqlIso8601), dtSqlIso8601, andB(iSqlFormat, dtsqlus), dtsqlus, andB(iSqlFormat, dtSqlManual), dtSqlManual, True, dtSqlDefault)
End Property
 
' Bei gewissen Methoden kann man das Rückgabetype auswählen
Public Property Get returnType() As dtReturnTypes
    returnType = pReturnTypes
End Property
Public Property Let returnType(ByVal iReturnType As dtReturnTypes)
    pReturnTypes = Switch(andB(iReturnType, dtDateTime), dtDateTime, andB(iReturnType, dtTimestamp), dtTimestamp, True, dtRetDefault)
End Property
 
'SQL Formatstring
Public Property Get sqlDateFormatString() As String
    sqlDateFormatString = Switch(sqlFormat = dtsqlus, C_SQL_DATE_US_FORMAT, sqlFormat = dtSqlIso8601, C_SQL_DATE_ISO8601_FORMAT, sqlFormat = dtSqlManual, pSqlDateFormatString)
End Property
Public Property Let sqlDateFormatString(ByVal iFormatString As String)
    pSqlDateFormatString = iFormatString
    sqlFormat = dtSqlManual
End Property
 
Public Property Get sqlDateTimeFormatString() As String
    sqlDateTimeFormatString = Switch(sqlFormat = dtsqlus, C_SQL_DATETIME_US_FORMAT, sqlFormat = dtSqlIso8601, C_SQL_DATETIME_ISO8601_FORMAT, sqlFormat = dtSqlManual, pSqlDateTimeFormatString)
End Property
Public Property Let sqlDateTimeFormatString(ByVal iFormatString As String)
    pSqlDateTimeFormatString = iFormatString
    sqlFormat = dtSqlManual
End Property
 
Public Property Get sqlTimeFormatString() As String
    sqlTimeFormatString = Switch(sqlFormat = dtsqlus, C_SQL_TIME_US_FORMAT, sqlFormat = dtSqlIso8601, C_SQL_TIME_ISO8601_FORMAT, sqlFormat = dtSqlManual, pSqlTimeFormatString)
End Property
Public Property Let sqlTimeFormatString(ByVal iFormatString As String)
    pSqlTimeFormatString = iFormatString
    sqlFormat = dtSqlManual
End Property
 
'/**
' * Gibt ein String-Wert eines Objektes zurück
' * @return String
' */
Public Property Get toString(Optional ByVal format As String) As String
    toString = IIf(format = Empty, sqlTimeStamp, Me.format(format))
End Property
 
'-------------------------------------------------------------------------------
' -- Interface methodes/properties
'-------------------------------------------------------------------------------
#If IFormattable_exists Then
    '/**
    ' * Gibt das Originalobjekt  zurück
    ' * @object
    ' */
    Private Property Get IFormattable_toString(Optional ByVal format As String, Optional ByRef formatProvider As Object) As String
        IFormattable_toString = toString(format)
    End Property
#End If
 
'-------------------------------------------------------------------------------
'--- PRIVATE PROPERTIES
'-------------------------------------------------------------------------------
'/**
' * Managt die gecachten Formate
' * @return Dictionary
' */
Private Property Get formatS() As Object
    Static cachedDict As Object
    If cachedDict Is Nothing Then Set cachedDict = CreateObject("scripting.Dictionary")
    Set formatS = cachedDict
End Property
 
 
'/**
' * RegExp der die Einzelformatpatterns bestimmt
' * @return RegExp
' */
Private Property Get rxParseFormat() As Object
    Static cachedRx As Object
    If cachedRx Is Nothing Then Set cachedRx = cRx("/((?=" & pPatternDelemiter & "?)(\\u[0-9A-F]{4})|(Y{4}|([MDHNSWYQ])\4|[MDHNSWYFQ]|A\/P|AM/PM))/ig")
    Set rxParseFormat = cachedRx
End Property
 
'/**
' * RegExp der die Einzelformatpatterns bestimmt
' * @return RegExp
' */
Private Property Get rxParseFormat2() As Object
    'cRx("/\{\$(.*?)\}/g")
    Static rx As Object:    If rx Is Nothing Then Set rx = cRx("/\{\$((\\u[0-9A-F]{4})|(Y{4}|([MDHNSWYQ])\4|[MDHNSWYFQ]|A\/P|AM/PM))}/ig")
    Set rxParseFormat2 = rx
End Property
 
Private Property Get rxExtractNanoSec() As Object
    Static rx As Object: If rx Is Nothing Then Set rx = cRx("/^(.*)(\.\d{1,9})$/")
    Set rxExtractNanoSec = rx
End Property
 
'/**
' * RegExp mit dem Nanosekundenformat
' * @return RegExp
' */
Private Property Get rxNS() As Object
    Static rx As Object: If rx Is Nothing Then Set rx = cRx("/(f{1,9})/ig")
    Set rxNS = rx
End Property
 
'/**
' * RegExp mit dem Nanosekundenformat bei format2()
' * @return RegExp
' */
Private Property Get rxNS2() As Object
    Static rx As Object: If rx Is Nothing Then Set rx = cRx("/(\{\$([^\}f]*))(f{1,9})(([^\}f]*)\})/i")
    Set rxNS2 = rx
End Property
 
'/**
' * RegExp um die Formatschnipsel bei format2() zu finden
' * @return RegExp
' */
Private Property Get rxFormats2() As Object
    Static rx As Object: If rx Is Nothing Then Set rx = cRx("/\{(?!\\)\$([^\}]+)}/")
    Set rxFormats2 = rx
End Property
 
'-------------------------------------------------------------------------------
' -- Private Methodes
'-------------------------------------------------------------------------------
 
'/**
' * Schneidet den Timestamp ab. Es wird ggf noch ein Delta dazu gerechnet
' * @param  String      Den Interval gemäss DateAdd()
' * @param  Byte        Ein Delta, dass auf der letzten Stelle dazugerecnet wird
' * @return Date
' */
Private Function truncTimestamp( _
        Optional ByVal iInterval As String = "D", _
        Optional ByVal iDelta As Integer = 0 _
) As Date
    Dim ts As Date: ts = timestamp
    Select Case UCase(iInterval)
        Case "YYYY", "YY", "Y": truncTimestamp = DateSerial(VBA.year(ts) + iDelta, 1, 1)
        Case "M", "MM":         truncTimestamp = DateSerial(VBA.year(ts), VBA.month(ts) + iDelta, 1)
        Case "D", "DD":         truncTimestamp = DateSerial(VBA.year(ts), VBA.month(ts), VBA.day(ts) + iDelta)
        Case "H", "HH":         truncTimestamp = DateSerial(VBA.year(ts), VBA.month(ts), VBA.day(ts)) + TimeSerial(VBA.hour(ts) + iDelta, 0, 0)
        Case "N", "NN":         truncTimestamp = DateSerial(VBA.year(ts), VBA.month(ts), VBA.day(ts)) + TimeSerial(VBA.hour(ts), VBA.minute(ts) + iDelta, 0)
        Case "S", "SS":
            'Die Nanosekunden sind bereits eingearbeitet. Darum müssen diese wieder entfernt werden
            iDelta = iDelta - CInt(nanoSecond / 10 ^ 9)
            truncTimestamp = DateSerial(VBA.year(ts), VBA.month(ts), VBA.day(ts)) + TimeSerial(VBA.hour(ts), VBA.minute(ts), VBA.second(ts) + iDelta)
        Case "W", "WW":         truncTimestamp = DateAdd("d", -CInt(VBA.format(ts, "w", pFirstDayOfWeek)) + 1, DateAdd("WW", iDelta, truncTimestamp("D")))
        Case Else:      Err.Raise 13, "DateTime.trunc"
    End Select
End Function
 
'/**
' * Ersezt einen einzelnen Teil des Timestamp
' * @param  String  Kurzzeichen des Abschnittes YMDHNS
' * @param  Integer Neuer Wert
' */
Private Sub replaceOnePart(ByVal iDatePartType As enuDatePartType, ByVal iValue As Integer)
    Select Case iDatePartType
        Case dptYear:       pTimeStamp = DateSerial(iValue, Me.month, Me.day) + Me.timeValue
        Case dptMonth:      pTimeStamp = DateSerial(Me.year, iValue, Me.day) + Me.timeValue
        Case dptDay:        pTimeStamp = DateSerial(Me.year, Me.month, iValue) + Me.timeValue
        Case dptHour:       pTimeStamp = Me.dateValue + TimeSerial(iValue, Me.minute, Me.second)
        Case dptMinute:     pTimeStamp = Me.dateValue + TimeSerial(Me.hour, iValue, Me.second)
        Case dptSecound:    pTimeStamp = Me.dateValue + TimeSerial(Me.hour, Me.minute, iValue)
    End Select
End Sub
 
'/**
' * Versucht aus einer Eingabe ein Datum zu erstellen
' * @param  Date/DateTime/String
' * @return Date
' */
Private Function getDate(ByRef iDate As Variant) As Date
    Select Case TypeName(iDate)
        Case "DateTime":    getDate = iDate.timestamp
        Case "Date":        getDate = iDate
        Case "String":      getDate = dateValue(iDate) + timeValue(dateValue)
        Case "Null":        getDate = Now
        Case Else:          Err.Raise 13, "DateInterval.getDate"          '13  Type mismatch
    End Select
End Function
 
'/**
' * Handelt den Return. Ob das aktuelle Objekt angepasst wird oder nicht
' * @param  Date
' * @param  Boolean     true: Das DateTimeObjekt wird selber verändert - False: Das Objekt selber wird nicht verändert
' * @return DateTime
' */
Private Function retDt(ByVal iTimestamp As Date, ByVal iNanoSecond As Variant, ByVal iByRef As Boolean) As DateTime
    If iByRef Then
        'Auf sich selber anpassen
        pTimeStamp = iTimestamp
        pNanoSecond = iNanoSecond
        Set retDt = Me
    Else
        'Neues Objekt erstellen. Die SQL-Formateinstellung wird ebenfalls übergeben
        Set retDt = DateTime.instance(iTimestamp, , Me.sqlFormat, firstDayOfWeek, firstWeekOfYear)
        retDt.nanoSecond = iNanoSecond
    End If
End Function
 
Private Sub refDt(ByRef oValue As Variant, ByVal iReturnType As dtReturnTypes, Optional ByRef iDt As DateTime = Nothing, Optional ByVal iByRef As Boolean = C_DEFAULT_BYREF)
    Dim dt As DateTime: Set dt = IIf(iDt Is Nothing, Me, iDt)
    Select Case iReturnType
        Case dtTimestamp:   oValue = dt.timestamp
        Case dtDateTime:    Set oValue = IIf(iByRef, dt, dt.clone)
    End Select
End Sub
 
'/**
' * Add/Minus ein DateInterval
' * @param  DateInterval/IntervalSpec/Days
' * @param  Boolean                             true: Das DateTimeObjekt wird selber verändert - False: Das Objekt selber wird nicht verändert
' * @return DateTime
' */
Private Function addInterval(ByRef iInterval As Variant, ByVal iSign As Integer, Optional ByVal iByRef As Boolean = C_DEFAULT_BYREF) As DateTime
    Dim di As DateInterval
    Select Case TypeName(iInterval)
        Case "DateInterval":    Set di = iInterval
        Case "String":          Set di = DateInterval(iInterval)
        Case "Integer", "Long": Set di = DateInterval(iInterval)
        Case Else:              Err.Raise 13, "DateTime.addInterval"
    End Select
    Dim sign As Integer:    sign = di.sign * iSign
    Dim ts As Date:         ts = pTimeStamp
    Dim nanoSec As Long:    nanoSec = pNanoSecond + sign * di.nanoSecond
    ts = DateAdd("YYYY", sign * di.year, ts)
    ts = DateAdd("M", sign * di.month, ts)
    ts = DateAdd("D", sign * di.day, ts)
    ts = DateAdd("H", sign * di.hour, ts)
    ts = DateAdd("N", sign * di.minute, ts)
    ts = DateAdd("S", sign * di.second, ts)
 
    Set addInterval = retDt(ts, nanoSec, iByRef)
End Function
 
'/**
' * Ermittelt den Jahrestag des Ersten Tages einer Woche
' * @param  Long    Jahr
' * @param  Integer Woche im Jahr
' * @param  VbDayOfWeek             Angabe zum ersten Wochentag. Schweiz -> Montag
' * @param  VbFirstWeekOfYear       Angabe zum ersten Woche im Jahr
' * @return Long
' */
Private Function getDaysOfFirstDayOfWeek( _
        ByVal iYear As Long, _
        ByVal iWeek As Integer, _
        Optional ByVal iFirstDayOfWeek As VbDayOfWeek = vbUseSystemDayOfWeek, _
        Optional ByVal iFirstWeekOfYear As VbFirstWeekOfYear = vbUseSystem _
) As Long
    Dim firstJan  As Date:      firstJan = DateSerial(iYear, 1, 1)
    Dim firstJanW As Integer:   firstJanW = DatePart("W", firstJan, iFirstDayOfWeek, vbFirstFullWeek)
    Dim diff As Integer:        diff = IIf(DatePart("WW", firstJan, iFirstDayOfWeek, iFirstWeekOfYear) = 1, firstJanW, firstJanW - 7)
    getDaysOfFirstDayOfWeek = ((iWeek - 1) * 7) + 2 - diff
End Function
 
'-------------------------------------------------------------------------------
' -- Class Events
'-------------------------------------------------------------------------------
 
'/**
' * Beim initialisieren gleich den Wert auf Now setzen
' */
Private Sub Class_Initialize()
    pPatternDelemiter = C_DEFAULT_PATTERN_DELEMITER
    construct Now
End Sub
 
'-------------------------------------------------------------------------------
'--- LIBRARIES
'-------------------------------------------------------------------------------
 
'-------------------------------------------------------------------------------
' -- strToDate V 2.5.0
'-------------------------------------------------------------------------------
 
'/**
' * Parst ein String in ein Datum anhand eines mitgegeben Formates
' * @param  String                  Der Datumsstring
' * @param  String                  Das Format. Als Standart ist das Systemdatumsformat
' * @param  tdtParams               Weitere Parameter
' * @param  VbDayOfWeek             Angabe zum ersten Wochentag. Schweiz -> Montag. Standard: Systemeinstellung
' * @param  VbFirstWeekOfYear       Angabe zum ersten Woche im Jahr. Schweiz -> vbFirstFourDays. Standard: Systemeinstellung
' * @param  Long                    Rückgabewert für die Nanosekunden
' * @return Date
' *
' * Die folgenden Zeichen müssen im Format mit einem \ maskiert werden, wenn sie als Trennzeichen eingesetzt werden sollen:
' * M D Y H N S W @    Bie AMPM: A\M/P\M, \A/P
' * Bsp.:   strToDate("D01M11Y2014", "\DDD\MMM\YYYYY") -> 1 November 2014
' *
' * Bisher umgesetzte Formate:
' * m       Monat ohne führende Null (1-12)
' * mm      Monat mit führende Null (01-12)
' * d       Tag ohne führende Null (1-31)
' * dd      Tag mit führende Null (01-31)
' * yy      Zweistelliges Jahr
' * yyyy    Vierstelliges Jahr
' * q       QuartalAnfang (1.1.x - 1.10.x)
' * qq      QuartalEnde   (31.3.x - 31.12.x)
' * h       Stunden ohne führende Null(0-24)
' * hh      Stunden mit führende Null(00-24)
' * n       Minuten ohne führende Null(0-59)
' * nn      Minuten mit führende Null(00-59)
' * s       Sekunden ohne führende Null(0-59)
' * ss      Sekunden mit führende Null(00-59)
' * am/pm   Erwartet eine Angabe von AM oder PM
' * a/p     Erwartet eine Angabe von A oder P
' * y       Tag des Jahres
' * w       Tag der Woche
' * ww      Woche im Jahr
' * f       Nanosekunden
' *
' * Allgemein. Sollte anhand des Formates eine Reihenfolge nicht klar sein, dann kann vor jedes Pattern ein @ gesetzt werden
' * Format "YYYYY". Jahreszahl & Tag im Jahr. Es ist unklar ob das Jahr oder der Tag als erste kommt. -> "Y2YYYY"
' *
' * Errors:
' * 13          Es wurde kein Format mitgegeben und der String lässt sich nicht durch das Sytem in ein Datum wandeln. Siehe cdate()
' * -2147221503 (C_SD_ERR_INVALID_FORMAT)   Das Format ist nicht parsbar
' * -2147221502 (C_SD_ERR_NOT_PARSEBLE)     Der String passt nicht mit dem Format überein
' */
Public Function strToDate( _
        ByVal iDate As Variant, _
        Optional ByVal iFormat As String = vbNullString, _
        Optional ByVal iparams As tdtParams = tdtIgnoreCase, _
        Optional ByVal iFirstDayOfWeek As VbDayOfWeek = vbUseSystemDayOfWeek, _
        Optional ByVal iFirstWeekOfYear As VbFirstWeekOfYear = vbUseSystem, _
        Optional ByRef oNanoSecounds As Variant _
) As Variant
On Error GoTo Err_Handler
 
    Dim dateS As String:     dateS = IIf(andB(iparams, tdtIgnoreCase), UCase(CStr(NZ(iDate))), CStr(NZ(iDate)))
    'Wenn kein Format mitgegen wird, wird versucht mittels cDate() das Datum herauszukriegen
    If iFormat = vbNullString Then
        strToDate = CDate(dateS)
        Exit Function
    End If
 
    Dim d As Integer, m As Integer, y As Integer: d = 1: m = 0: y = 0
    Dim h As Integer, n As Integer, s As Integer: h = 0: n = 0: s = 0
    Dim dow As Integer, doy As Long, woy As Integer: dow = 0: doy = 0: woy = 0
    Dim ampm As String
    Dim flagHasDate As Boolean
    Dim flagHasTime As Boolean
 
    'überprüfen, welcher Art von Format es ist
    If Not andB(iparams, tdtFomat2) And rxParseFormat2.test(iFormat) Then iparams = iparams + tdtFomat2
 
    'Format parsen
    Dim frmtKey As String: frmtKey = parseFormatToCache(iFormat, iparams)
 
    'Überprüfen ob der Datumsstring auf das Format passt
    If formatS(frmtKey).item("RegExp").test(dateS) = False Then Err.Raise dtErrNotParseble, "strToDate", "Datum passt nicht auf das Format" & vbCrLf & vbCrLf & formatS(frmtKey).item("RegExp").pattern
 
    Dim match As Object: Set match = formatS(frmtKey).item("RegExp").execute(dateS)(0)
    Dim i As Integer: For i = 0 To match.subMatches.Count - 1
        Dim sm As String: sm = match.subMatches(i)
        Dim parser As tdParser: parser = formatS(frmtKey).item("codePos")(i)
        flagHasDate = (andB(pcDate, parser) Or flagHasDate)
        flagHasTime = (andB(pcTime, parser) Or flagHasTime)
        Select Case parser
            Case pcDay:         d = sm
            Case pcMonth:       m = sm
            Case pcYear:        y = sm
            Case pcHour:        h = sm
            Case pcMinute:      n = sm
            Case pcSecound:     s = sm
            Case pcAmPm:        ampm = UCase(Left(sm, 1))
            Case pcDayOfYear:   doy = sm
            Case pcDayOfWeek:   dow = sm
            Case pcWeekOfYear:  woy = sm
            Case pcNonosecound: oNanoSecounds = 10 ^ 9 * CDbl("0." & sm)
            Case pcQuarterEnd:  d = 0: m = sm * 3 + 1
            Case pcQuarter:     d = 1: m = (sm - 1) * 3 + 1
        End Select
    Next i
 
    'Spezialfälle, welche bestehende Grössen überschreiben
    If doy <> 0 Then        'Tag des Jahres
        m = 1               'Monat auf Januar setzen
        d = doy             'Tag des Jehres als Tag übernehmen
    ElseIf woy <> 0 Then    'Woche des Jahres
        m = 1               'Monat auf Januar setzen
        d = getDaysOfFirstDayOfWeek(y, woy, iFirstDayOfWeek, iFirstWeekOfYear) + IIf(dow = 0, 0, (dow - 1))
    End If
 
    'AM/PM Stundenkorrektur
    If ampm = "P" And h <> 0 And h < 12 Then
        h = h + 12
    ElseIf ampm = "A" And h = 12 Then
        h = 0
    End If
 
    strToDate = IIf(flagHasDate, DateSerial(y, m, d), 0) + IIf(flagHasTime, TimeSerial(h, n, s), 0)
 
    Set match = Nothing
 
Exit_Handler:
    Set match = Nothing
    Exit Function
Err_Handler:
    If Not andB(iparams, tdtIgnoreError) Then Err.Raise Err.Number, Err.source, Err.Description, Err.HelpFile, Err.helpContext
    strToDate = Null
    Resume Exit_Handler
    Resume
End Function
 
'-------------------------------------------------------------------------------
'--- PRIVATE METHODES
'-------------------------------------------------------------------------------
 
'/**
' * Zerlegt das Format in seine Einzelteile und erstellt ein RegEx-Pattern umd den Datumsstring zu zerlegen
' * @param  String      Das Format. Als Standart ist das Systemdatumsformat
' * @param  tdtParams   Weitere Parameter
' * @return String      Key des gecachten RegExp
' */
Private Function parseFormatToCache(ByVal iFormat As String, ByVal iparams As tdtParams) As String
    parseFormatToCache = iFormat & "_P" & iparams
    'Das Format nur zerlegen, wenn es noch nicht exisiteiert
    If Not formatS.exists(parseFormatToCache) Then
        Dim codePosR() As tdParser
 
        Dim frmt As String:         frmt = IIf(andB(iparams, tdtIgnoreCase), UCase(iFormat), iFormat)
        Dim pattern As String:
 
        Dim rxPF As Object
        If Not andB(iparams, dtInFormatFormat2) Then
            pattern = masked2uniode(frmt)
            pattern = rxEscapeString(pattern)
            Set rxPF = rxParseFormat
        Else
            pattern = frmt
            Set rxPF = rxParseFormat2
        End If
        If rxPF.test(pattern) = False Then Err.Raise dtErrInvalidFormat, "strToDate", "Ungültiges Datumsformat"
        Dim mc As Object:  Set mc = rxPF.execute(pattern)
 
        Dim idxPos As Integer:      idxPos = -1
        Dim i As Integer:           For i = mc.Count - 1 To 0 Step -1
            Dim item As String:     item = mc(i).subMatches(2)
            If Not item = Empty Then 'Ist kein Maskiertes Zeichen
                idxPos = idxPos + 1: ReDim Preserve codePosR(idxPos)
                pattern = substrReplace(pattern, convertFormatPattern(item, codePosR(idxPos)), mc(i).firstIndex, mc(i).length)
            End If
        Next i
        'Patterntrennzeichen entfernen
        pattern = Replace(pattern, C_PATTERN_DELEMITER, "")
        'Reihenfolge der codePosR umdrehen
        Dim codePos() As String:    ReDim codePos(idxPos)
        For i = 0 To idxPos
            codePos(i) = codePosR(idxPos - i)
        Next i
        pattern = unicodeDecode(pattern)
        If Not andB(iparams, tdtExtractDate) Then pattern = "^" & pattern & "$"
        pattern = "/" & pattern & "/" & IIf(andB(iparams, tdtIgnoreCase), "i", "")
 
        formatS.add parseFormatToCache, CreateObject("scripting.Dictionary")
        'RegExp zu diesem Pattrn erstellen
        formatS(parseFormatToCache).add "codePos", codePos      'Index der SubMatches
        formatS(parseFormatToCache).add "RegExp", cRx(pattern)
    End If
End Function
 
'/**
' * Maskiert einen String, damit er keine Pattern darstellt
' * @param  String
' * @return String
' */
Private Function rxEscapeString(ByVal iString As String) As String
    Static rx As Object
    If rx Is Nothing Then Set rx = cRx("/([\*\+\?\|\{\[\(\)\^\.\$])/gi")    '\ wird nicht maskiert
    rxEscapeString = rx.Replace(iString, "\$1")
End Function
 
'/**
' * Konvertiert ein gefundenen Formatteil in ein RX-Pattern. Gibt Zugleich den Datumsparser zurück
' * @param  String
' * @param  tdParser
' * return  String
' */
Private Function convertFormatPattern(ByVal iString As String, ByRef oCode As tdParser) As String
    Select Case UCase(iString)
        Case "D":       convertFormatPattern = "(\d{1,2})":     oCode = pcDay
        Case "DD":      convertFormatPattern = "(\d{2})":       oCode = pcDay
        Case "M":       convertFormatPattern = "(\d{1,2})":     oCode = pcMonth
        Case "MM":      convertFormatPattern = "(\d{2})":       oCode = pcMonth
        Case "YY":      convertFormatPattern = "(\d{2}|\d{4})": oCode = pcYear
        Case "YYYY":    convertFormatPattern = "(\d{4})":       oCode = pcYear
        Case "H":       convertFormatPattern = "(\d{1,2})":     oCode = pcHour
        Case "HH":      convertFormatPattern = "(\d{2})":       oCode = pcHour
        Case "N":       convertFormatPattern = "(\d{1,2})":     oCode = pcMinute
        Case "NN":      convertFormatPattern = "(\d{2})":       oCode = pcMinute
        Case "S":       convertFormatPattern = "(\d{1,2})":     oCode = pcSecound
        Case "SS":      convertFormatPattern = "(\d{2})":       oCode = pcSecound
        Case "AM/PM":   convertFormatPattern = "(AM|PM)":       oCode = pcAmPm
        Case "A/P":     convertFormatPattern = "([AP])":        oCode = pcAmPm
        Case "Y":       convertFormatPattern = "(\d{1,3})":     oCode = pcDayOfYear
        Case "W":       convertFormatPattern = "([1234567])":   oCode = pcDayOfWeek
        Case "WW":      convertFormatPattern = "(\d{1,2})":     oCode = pcWeekOfYear
        Case "F":       convertFormatPattern = "(\.?\d{1,9})":  oCode = pcNonosecound
        Case "QQ":      convertFormatPattern = "([1-4])":       oCode = pcQuarterEnd
        Case "Q":       convertFormatPattern = "([1-4])":       oCode = pcQuarter
    End Select
End Function
 
'-------------------------------------------------------------------------------
'--- PRIVATE PROPERTIES
'-------------------------------------------------------------------------------
 
'-------------------------------------------------------------------------------
'--- LIBRARIES
'-------------------------------------------------------------------------------
 
'/**
' * Dies ist die Minimalversion von cRx (V2.1.0): http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cRx
' */
Private Function cRx(ByVal iPattern As String) As Object
    Static rxP As Object
    If rxP Is Nothing Then:     Set rxP = CreateObject("VBScript.RegExp"): rxP.pattern = "^([@&!/~#=\|])?(.*)\1(?:([Ii])|([Gg])|([Mm]))*$"
    Dim sm As Object:           Set cRx = CreateObject("VBScript.RegExp"): Set sm = rxP.execute(iPattern)(0).subMatches
    cRx.pattern = sm(1):        cRx.IgnoreCase = Not isEmpty(sm(2)):       cRx.Global = Not isEmpty(sm(3)):     cRx.Multiline = Not isEmpty(sm(4))
End Function
 
'/**
' * Copyright mpl by ERB software | http://wiki.yaslaw.info
' *
' * Wandelt ein Unicode in ein Charakter
' * @example: unicode2char("\u20AC") -> '\€'
' * @param  String      Unicode
' * @return String      Char
' */
Private Function unicode2Char(ByVal iUnicode As String) As String
    unicode2Char = ChrW(Replace(iUnicode, "\u", "&h"))
End Function
 
'/**
' * Copyright mpl by ERB software | http://wiki.yaslaw.info
' *
' * Wandelt ein Charakter in ein Unicode
' * @example: char2unicode("€") -> '\u20AC'
' * @param  String(1)   Charakter, der gewandelt werden soll
' * @return String      Unicode
' */
Private Function char2unicode(ByVal iChar As String) As String
    char2unicode = Hex(AscW(iChar)) 'Hex-Wert ermitteln
    char2unicode = "\u" & String(4 - Len(char2unicode), "0") & char2unicode
End Function
 
'/**
' * Wandelt jedes mit \ maskierte Feld in Unicode um, ausser es handelt sich bereits um einen Unicode
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/masked2unicode
' * @param  String
' * @return String
' */
Private Function masked2uniode(ByVal iString As String) As String
    Static rx As Object:    If rx Is Nothing Then Set rx = cRx("/\\(?!u[0-9A-F]{4})(.)/")
    masked2uniode = iString
    Do While rx.test(masked2uniode)
        masked2uniode = rx.Replace(masked2uniode, char2unicode(rx.execute(masked2uniode)(0).subMatches(0)))
    Loop
End Function
 
'/**
' * Wandelt alle Unicodes in einem String in das eigentliche Zeichen zurück
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/unicodedecode
' * @param  String
' * @return String
' */
Private Function unicodeDecode(ByVal iString) As String
    unicodeDecode = iString
    Static rx As Object
    If rx Is Nothing Then Set rx = cRx("/\\u[0-9A-F]{4}/g")
    If Not rx.test(unicodeDecode) Then Exit Function
    Dim mc As Object:   Set mc = rx.execute(unicodeDecode)
    Dim i As Integer:   For i = mc.Count - 1 To 0 Step -1
        unicodeDecode = substrReplace(unicodeDecode, unicode2Char(mc(i)), mc(i).firstIndex, mc(i).length)
    Next i
End Function
 
'/**
' * Ersetzt Text innerhalb einer Zeichenkette
' * @param  String      Die Eingabezeichenkette
' * @param  String      Die Ersetzungszeichenkette
' * @param  Integer     Start
' * @param  Integer     Länge
' * @return String
' */
Private Function substrReplace(ByVal iString As String, ByVal iReplacement As String, ByVal iStart As Integer, Optional ByVal iLength As Variant = Null) As String
    Dim startP As Integer:  startP = IIf(Sgn(iStart) >= 0, iStart, greatest(Len(iString) + iStart, 1))
    Dim length As Integer:  length = NZ(iLength, Len(iString) - iStart)
    Dim endP   As Integer
 
    Select Case Sgn(length)
        Case 1:     endP = least(startP + length, Len(iString))
        Case 0:     endP = startP
        Case -1:    endP = greatest(Len(iString) + length, startP)
    End Select
 
    substrReplace = Left(iString, startP) & iReplacement & Mid(iString, endP + 1)
 
End Function
 
'/**
' * Copyright mpl by ERB software | http://wiki.yaslaw.info
' *
' * Gibt den Grössten aus einer unbestimmten Menge von Werten zurück
' * @param  Keine Objekte
' * @return Grösster Wert
' * @example greatest("Hallo Welt", 42, "Mister-X") -> Mister-X
'*/
Private Function greatest(ParamArray iItems() As Variant) As Variant
    greatest = iItems(UBound(iItems))
    Dim item As Variant: For Each item In iItems
        If NZ(item) > NZ(greatest) Then greatest = item
    Next item
End Function
 
'/**
' * Gibt den Kleinsten aus einer unbestimmten Menge von Werten zurück
' * @param  Keine Objekte
' * @return Grösster Wert
' * @example least("Hallo Welt", 42, "Mister-X") -> 42
'*/
Private Function least(ParamArray iItems() As Variant) As Variant
    least = iItems(LBound(iItems))
    Dim item As Variant: For Each item In iItems
        If NZ(item) < NZ(least) Then least = item
    Next item
End Function
 
'// Provided by Daniel Maher.
Private Function getISOWeekNum(ByVal iDate As Date, Optional ByVal iFirstDayOfWeek As VbDayOfWeek = vbUseSystemDayOfWeek, Optional ByVal iFirstWeekOfYear As VbFirstWeekOfYear = vbUseSystem) As Integer
   Dim tempDate As Date
   tempDate = DateSerial(VBA.year(iDate - DatePart("W", iDate - 1, iFirstDayOfWeek, iFirstWeekOfYear) + 4), 1, 3)
   getISOWeekNum = Int((iDate - tempDate + DatePart("W", tempDate, iFirstDayOfWeek, iFirstWeekOfYear) + 5) / 7)
End Function
 
'/**
' * Macht einen Bit-Vergleich
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/andb
' * @param  Long
' * @param  Long
' * @return Boolean
' */
Private Function andB(ByVal iHaystack As Long, ByVal iNeedle As Long) As Boolean
    andB = ((iHaystack And iNeedle) = iNeedle)
End Function
 
#If Not isAccess Then
    '/**
    ' * Wandelt NULL in EMpty oder einen Defaultwert
    ' * @param  Variant
    ' * @param  Variant
    ' * @return Variant
    ' */
    Private Function NZ(ByRef iValue As Variant, Optional ByRef iDefault As Variant = Empty) As Variant
        If IsNull(iValue) Then
            NZ = iDefault
        Else
            NZ = iValue
        End If
    End Function
#End If