Attribute VB_Name = "cast_strToDate"
'-------------------------------------------------------------------------------
'File         : cast_strToDate.bas
'               Copyright mpl by ERB software
'               All rights reserved
'               http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/strtodate
'Environment  : VBA 2007 +
'Version      : 2.5.0
'Name         : strToDate
'Author       : Stefan Erb (ERS)
'History      : 13.11.2013 - ERS - Creation
'             : 22.01.2014 - ERS - Platzhalterzeichen als Trennzeichen erlaubt
'               ...
'               07.09.2015 - ERS - Null und Zahlen als Input zugelassen
'               29.09.2015 - ERS - Berechnungsfehler bei w und ww mit vbFirstFullWeek behoben
'               17.11.2015 - ERS - q und qq hinzugefügt
'               15.03.2016 - ERS - Format2 hinzugefügt. Also Formate in {$..}
'-------------------------------------------------------------------------------
'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

Option Explicit
'-------------------------------------------------------------------------------
' -- ! SETTINGS !
'-------------------------------------------------------------------------------


'   date = strToDate(string [,format [,parameters [,erster Tag der Woche [,erste Woche des Jahres [,nanosekunden]]]]])

'-------------------------------------------------------------------------------
'--- PUBLIC MEMBERS
'-------------------------------------------------------------------------------

'/**
' * Zusätzliche Parameters zu strToDate
' */
Public Enum tdtParams
    tdtNone = 0
    tdtIgnoreCase = 2 ^ 0   'Gross-Kleinschreibung bei Trennzeichen ignorieren
    tdtExtractDate = 2 ^ 1  'Der String beimnhaltet vor oder nach dem Datum noch andere Werte. Das Datum wird extrahiert
    tdtIgnoreError = 2 ^ 2  'Fehler werden ignoriert. Im Fehlerfall wird NULL zurückgegeben
    tdtFomat2 = 2 ^ 3       'Es handelt sich um ein Format im Stil von {$DD}.{$MM}
End Enum

'/**
' * Public Konstanten
' */
Public Const C_PATTERN_DELEMITER = "@"     'Fakultatives Patterntrennzeichen

'/**
' * Error Konstantens
' */
Public Const C_SD_ERR_INVALID_FORMAT = -2147221504 + 1  'Das Format ist nicht parsbar
Public Const C_SD_ERR_NOT_PARSEBLE = -2147221504 + 2    'Der String passt nicht mit dem Format überein

'-------------------------------------------------------------------------------
'--- PUBLIC METHODES
'-------------------------------------------------------------------------------

'/**
' * 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
' * Bsp.:   strToDate("D01M11Y2014", "D{$DD}M{$MM}Y{$YYYY}") -> 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 Long _
) As Variant
On Error GoTo Err_Handler

    Dim dates As String:     dates = IIf((iParams And 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 = 0: 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
    
    'überprüfen, welcher Art von Format es ist
    If Not (iParams And tdtFomat2) = 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 C_SD_ERR_NOT_PARSEBLE, "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)
        Select Case formats(frmtKey).item("codePos")(i)
            Case "DAY":             d = sm
            Case "MONTH":           m = sm
            Case "YEAR":            y = sm
            Case "HOUR":            h = sm
            Case "MINUTE":          n = sm
            Case "SECOUND":         s = sm
            Case "AM/PM":           ampm = UCase(Left(sm, 1))
            Case "DAY_OF_YEAR":     doy = sm
            Case "DAY_OF_WEEK":     dow = sm
            Case "WEEK_OF_YEAR":    woy = sm
            Case "NONOSECOUND":     oNanoSecounds = 10 ^ 9 * CDbl("0." & sm)
            Case "QUARTER":         d = 1: m = (sm - 1) * 3 + 1
            Case "QUARTER_END":     d = 0: m = sm * 3 + 1
        End Select
    Next i

    'Spezialfälle, welche pestehende 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(y + m + d <> 0, DateSerial(y, m, d), 0) + IIf(h + n + s <> 0, TimeSerial(h, n, s), 0)

    Set match = Nothing

Exit_Handler:
    Set match = Nothing
    Exit Function
Err_Handler:
    If Not (iParams And tdtIgnoreError) = tdtIgnoreError Then Err.Raise Err.number, Err.source, Err.DESCRIPTION, Err.HelpFile, Err.HelpContext
    strToDate = Null
    Resume Exit_Handler
    Resume
End Function

'-------------------------------------------------------------------------------
'--- PRIVATE METHODES
'-------------------------------------------------------------------------------
'/**
' * 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

'/**
' * 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 String
    
        Dim frmt As String:         frmt = IIf((iParams And tdtIgnoreCase), UCase(iFormat), iFormat)
        Dim pattern As String:
        
        Dim rxPF As Object
        If Not (iParams And tdtFomat2) = tdtFomat2 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 C_SD_ERR_INVALID_FORMAT, "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 (iParams And tdtExtractDate) = tdtExtractDate Then pattern = "^" & pattern & "$"
        pattern = "/" & pattern & "/" & IIf((iParams And tdtIgnoreCase) = 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 Datumsteil zurück
' * @param  String
' * @param  String
' * return  String
' */
Private Function convertFormatPattern(ByVal iString As String, ByRef oCode As String) As String
    Select Case UCase(iString)
        Case "D":       convertFormatPattern = "(\d{1,2})":     oCode = "DAY"
        Case "DD":      convertFormatPattern = "(\d{2})":       oCode = "DAY"
        Case "M":       convertFormatPattern = "(\d{1,2})":     oCode = "MONTH"
        Case "MM":      convertFormatPattern = "(\d{2})":       oCode = "MONTH"
        Case "YY":      convertFormatPattern = "(\d{2}|\d{4})": oCode = "YEAR"
        Case "YYYY":    convertFormatPattern = "(\d{4})":       oCode = "YEAR"
        Case "H":       convertFormatPattern = "(\d{1,2})":     oCode = "HOUR"
        Case "HH":      convertFormatPattern = "(\d{2})":       oCode = "HOUR"
        Case "N":       convertFormatPattern = "(\d{1,2})":     oCode = "MINUTE"
        Case "NN":      convertFormatPattern = "(\d{2})":       oCode = "MINUTE"
        Case "S":       convertFormatPattern = "(\d{1,2})":     oCode = "SECOUND"
        Case "SS":      convertFormatPattern = "(\d{2})":       oCode = "SECOUND"
        Case "AM/PM":   convertFormatPattern = "(AM|PM)":       oCode = "AM/PM"
        Case "A/P":     convertFormatPattern = "([AP])":        oCode = "AM/PM"
        Case "Y":       convertFormatPattern = "(\d{1,3})":     oCode = "DAY_OF_YEAR"
        Case "W":       convertFormatPattern = "([1234567])":   oCode = "DAY_OF_WEEK"
        Case "WW":      convertFormatPattern = "(\d{1,2})":     oCode = "WEEK_OF_YEAR"
        Case "F":       convertFormatPattern = "(\.?\d{1,9})":  oCode = "NONOSECOUND"
        Case "QQ":      convertFormatPattern = "([1-4])":       oCode = "QUARTER_END"
        Case "Q":       convertFormatPattern = "([1-4])":       oCode = "QUARTER"
    End Select
End Function

'-------------------------------------------------------------------------------
'--- 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("/((?=" & C_PATTERN_DELEMITER & "?)(\\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

'-------------------------------------------------------------------------------
'--- 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

#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