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.1.0
'Name         : strToDate
'Author       : Stefan Erb (ERS)
'History      : 13.11.2013 - ERS - Creation
'             : 22.01.2014 - ERS - Platzhalterzeichen als Trennzeichen erlaubt
'               ...
'               18.11.2014 - ERS - Totalüberholung
'               03.12.2014 - ERS - cRegExp() durch cRx() ersetzt, maskStringWithUnicode() durch masked2uniode() ersetzt
'               15.04.2015 - ERS - yy erkennt jetzt auch yyyy
'               16.04.2015 - ERS - Ergänzung des FLags isAccess umd ie Funktion Excel-Tauglich zu machen
'-------------------------------------------------------------------------------
'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]])

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

'/**
' * Error Konstanten
' */
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
' * @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    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
' * 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
' *
' * 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 iDateS As String, _
        Optional ByVal iFormat As String = vbNullString, _
        Optional ByVal iParams As tdtParams = tdtIgnoreCase _
) As Date
    Dim dateS       As String:      dateS = IIf((iParams And tdtIgnoreCase), UCase(iDateS), iDateS)
    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 ampm        As String
    
    'Wenn kein Format mitgegen wird, wird versucht mittels cDate() das Datum herauszukriegen
    If iFormat = vbNullString Then
        strToDate = CDate(dateS)
        Exit Function
    End If

    '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))
        End Select
    Next i

    '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
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 String
    
        Dim frmt As String:         frmt = IIf((iParams And tdtIgnoreCase), UCase(iFormat), iFormat)
        Dim pattern As String:      pattern = masked2uniode(frmt)
        pattern = rxEscapeString(pattern)
        
        If rxParseFormat.test(pattern) = False Then Err.Raise C_SD_ERR_INVALID_FORMAT, "strToDate", "Ungültiges Datumsformat"
        Dim mc As Object:  Set mc = rxParseFormat.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(1)
            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
        
        '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
        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"
    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("/(?:(\\u[0-9A-F]{4})|(Y{4}|([MDHNSWY])\3|[MDHNSW]|A\/P|AM/PM))/ig")
    Set rxParseFormat = cachedRx
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