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      : 1.2.0
'Name         : strToDate
'Author       : Stefan Erb (ERS)
'History      : 13.11.2013 - ERS - Creation
'             : 22.01.2014 - ERS - Platzhalterzeichen als Trennzeichen erlaubt
'               n/a        - ERS - Neue Parameters
'               29.09.2014 - ERS - Cache in Properties ausgelagert, RegExp umgestellt, reset entfernt
'-------------------------------------------------------------------------------
Option Explicit

'   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

'-------------------------------------------------------------------------------
'--- PRIVATE MEMBERS
'-------------------------------------------------------------------------------

'/**
' * Cache der regExp um die Funktionen bei mehrmaligem gebruach mit denselben
' * Format zu beschleunigen
' */
Private pCacheFormats    As Object   'Ein Dictionary, dass alle für benutzten Formate den RegExp und die restlichen Infos speichert
Private pCacheDFRx       As Object   'RegEx um das Format in seine Einzelteile zu zerlegen
Private pCacheToAscRx    As Object   'RegEx um die Sondertrennzeichen in Ascii-Werte zu wandeln
Private pCacheToChrRx    As Object   'RegEx um sie wieder zurückzuwandeln

'-------------------------------------------------------------------------------
'--- LIBRARIES MEMBERS
'-------------------------------------------------------------------------------

' /**
' * Wird für die regExp Funktionen verwendet
' * Setzte die Flags für das RegExp Object
' */
Private Enum rxpFlagsEnum
    rxpNone = 2 ^ 0          'Value 1
    rxpGlobal = 2 ^ 1        'Value 2   Modifier g Global
    rxpIgnorCase = 2 ^ 2     'Value 4   Modifier i IgnoreCase
    rxpMultiline = 2 ^ 3     'Value 8   Modifier m multiLine
End Enum
'-------------------------------------------------------------------------------
'--- 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
' * 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 cacheFormats(frmtKey).item("RegExp").Test(dateS) = False Then Err.Raise C_SD_ERR_NOT_PARSEBLE, "strToDate", "Datum passt nicht auf das Format" & vbCrLf & vbCrLf & cacheFormats(frmtKey).item("RegExp").pattern

    Dim mc As Object: Set mc = cacheFormats(frmtKey).item("RegExp").execute(dateS)
    Dim i As Integer: For i = 0 To mc(0).SubMatches.count - 1
        Select Case cacheFormats(frmtKey).item("Position")(i)
            Case "DAY":     d = mc(0).SubMatches(i)
            Case "MONTH":   m = mc(0).SubMatches(i)
            Case "YEAR":    y = mc(0).SubMatches(i)
            Case "HOUR":    h = mc(0).SubMatches(i)
            Case "MINUTE":  n = mc(0).SubMatches(i)
            Case "SECOUND": s = mc(0).SubMatches(i)
            Case "AM/PM":   ampm = UCase(mc(0).SubMatches(i))
        End Select
    Next i

    'AM/PM Stundenkorrektur
    If ampm Like "P*" And h <> 0 And h < 12 Then
        h = h + 12
    ElseIf ampm Like "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 mc = Nothing
End Function

'-------------------------------------------------------------------------------
'--- PRIVATE METHODES
'-------------------------------------------------------------------------------

'/**
'* Zerlegt das Format in seine Einzelteile
' * @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 cacheFormats.exists(parseFormatToCache) Then
        Dim frmt As String: frmt = IIf((iParams And tdtIgnoreCase), UCase(iFormat), iFormat)
        Dim i As Integer
        Dim mc As Object
        
        'Maskierte Patterns durch Ascii-Werte ersetzn. \m -> {#109}
        If cacheToAscRx.Test(frmt) Then
            Set mc = cacheToAscRx.execute(frmt)
            For i = mc.count - 1 To 0 Step -1
                frmt = Left(frmt, mc(i).firstIndex) & "{#" & Asc(mc(i).SubMatches(0)) & "}" & Mid(frmt, mc(i).firstIndex + Len(mc(0)) + 1)
            Next i
        End If

        'Prüfen ob das Format überhaubt einen Treffer hat
        If cacheDFRx.Test(frmt) = False Then Err.Raise C_SD_ERR_INVALID_FORMAT, "strToDate", "Ungültiges Datumsformat"
        Set mc = cacheDFRx.execute(frmt)

        Dim patternItems() As String: ReDim patternItems(mc.count)
        Dim position() As String: ReDim position(mc.count - 1)

        Dim pos As Integer: pos = 0     'Letzte Position im String
        For i = 0 To mc.count - 1
            'Alles was zwischen der letzten Endposition und dem neuen Start liegt auslesen
            Dim val As String: val = Mid(frmt, pos + 1, mc(i).firstIndex - pos)
            'Pattern auswählen
            Select Case UCase(mc(i))
                Case "D":       patternItems(i) = val & "(\d{1,2})":    position(i) = "DAY"
                Case "DD":      patternItems(i) = val & "(\d{2})":      position(i) = "DAY"
                Case "M":       patternItems(i) = val & "(\d{1,2})":    position(i) = "MONTH"
                Case "MM":      patternItems(i) = val & "(\d{2})":      position(i) = "MONTH"
                Case "YY":      patternItems(i) = val & "(\d{2})":      position(i) = "YEAR"
                Case "YYYY":    patternItems(i) = val & "(\d{4})":      position(i) = "YEAR"
                Case "H":       patternItems(i) = val & "(\d{1,2})":    position(i) = "HOUR"
                Case "HH":      patternItems(i) = val & "(\d{2})":      position(i) = "HOUR"
                Case "N":       patternItems(i) = val & "(\d{1,2})":    position(i) = "MINUTE"
                Case "NN":      patternItems(i) = val & "(\d{2})":      position(i) = "MINUTE"
                Case "S":       patternItems(i) = val & "(\d{1,2})":    position(i) = "SECOUND"
                Case "SS":      patternItems(i) = val & "(\d{2})":      position(i) = "SECOUND"
                Case "AM/PM":   patternItems(i) = val & "(AM|PM)":      position(i) = "AM/PM"
                Case "A/P":     patternItems(i) = val & "(A|P)":        position(i) = "AM/PM"
            End Select
            'Endposition setzen
            pos = mc(i).firstIndex + Len(mc(i))
        Next i
        'Noch alles nach dem letzten Treffer mitnehmen
        patternItems(mc.count) = Mid(frmt, pos + 1)

        'Pattern aus den Einzelteilen zusammensatzen
        Dim pattern As String: pattern = Join(patternItems, "")

        'Ascii-Werte zu Character Werte zurückwandeln {#109} -> m
        If cacheToChrRx.Test(pattern) Then
            Set mc = cacheToChrRx.execute(pattern)
            For i = mc.count - 1 To 0 Step -1:  pattern = Replace(pattern, mc(i), Chr(mc(i).SubMatches(0))):    Next i
        End If

        If Not (iParams And tdtExtractDate) = tdtExtractDate Then pattern = "^" & pattern & "$"

        cacheFormats.add parseFormatToCache, CreateObject("scripting.Dictionary")
        'RegExp zu diesem Pattrn erstellen
        With cacheFormats(parseFormatToCache)
            .add "Position", position
            .add "RegExp", cRegExp(pattern, IIf((iParams And tdtIgnoreCase) = tdtIgnoreCase, rxpIgnorCase, rxpNone))
        End With
    End If
End Function


'-------------------------------------------------------------------------------
'--- PRIVATE PROPERTIES
'-------------------------------------------------------------------------------

'/**
' * Managt die gecachten Formate
' * @return Dictionary
' */
Private Property Get cacheFormats() As Object
    If pCacheFormats Is Nothing Then Set pCacheFormats = CreateObject("scripting.Dictionary")
    Set cacheFormats = pCacheFormats
End Property

'/**
' * RegExp der die Einzelformatpatterns bestimmt
' * @return RegExp
' */
Private Property Get cacheDFRx() As Object
    If pCacheDFRx Is Nothing Then Set pCacheDFRx = cRegExp("(m{1,2}|d{1,2}|y{4}|y{2}|h{1,2}|n{1,2}|s{1,2}|AM\/PM|A\/P|w{1,2})(?!\\(?!\\))", rxpGlobal + rxpIgnorCase)
    Set cacheDFRx = pCacheDFRx
End Property

'/**
' * Maskierte Formatpattern
' * @return RegExp
' */
Private Property Get cacheToAscRx() As Object    'RegEx um die Sondertrennzeichen in Ascii-Werte zu wandeln
    If pCacheToAscRx Is Nothing Then Set pCacheToAscRx = cRegExp("\\([mdyhns])", rxpGlobal + rxpIgnorCase)
    Set cacheToAscRx = pCacheToAscRx
End Property
Private Property Get cacheToChrRx() As Object    'RegEx um sie wieder zurückzuwandeln
    If pCacheToChrRx Is Nothing Then Set pCacheToChrRx = cRegExp("\{#(\d{1,3})\}", rxpGlobal + rxpIgnorCase)
    Set cacheToChrRx = pCacheToChrRx
End Property


'-------------------------------------------------------------------------------
'--- LIBRARIES
'-------------------------------------------------------------------------------

'/**
' * Erstellt ein RegExp-Object mit den Grundeinstellungen
' * V2.0.0
' * @param  String          Pattern analog RegExp
' * @param  rxpFlagsEnum    Eigenschaften von Regexp. Global, IgnoreCase und Multiline.
' *                         Die Eigenschaften können mit + kombiniert werden
' * @return RegExp
' */
Private Function cRegExp( _
        ByVal iPattern As String, _
        Optional ByVal iFlag As rxpFlagsEnum = rxnone _
) As Object
    Set cRegExp = CreateObject("VBScript.RegExp")
    cRegExp.pattern = iPattern
    cRegExp.Global = iFlag And rxpGlobal
    cRegExp.IgnoreCase = iFlag And rxpIgnorCase
    cRegExp.Multiline = iFlag And rxpMultiline
End Function