Attribute VB_Name = "lib_printF"
'-------------------------------------------------------------------------------
'File         : lib_printF.bas
'               Copyright mpl by ERB software
'               All rights reserved
'               http://wiki.yaslaw.info/doku.php/vba/functions/printf/index
'Environment  : VBA XP - 2010
'Version      : 2.7.1
'Name         : PrintF
'Author       : Stefan Erb (ERS)
'History      : 04.04.2013 - 1.0.0 - ERS - Creation
'               ...
'               03.03.2015 - 2.1.0 - ERS - NZ für Excel eingefügt (Siehe #cont isAccess), eval("#" & value & "#") durch DateValue(value) ersetzt
'               29.01.2016 - 2.2.0 - ERS - Formate für Datum hinzugefügt, < Als Positionszeichen hinzugefügt
'               26.09.2016 - 2.3.0 - ERS - Neues Datumsformat o Und O hinzugeügt. Fehler behoben: Wenn in einem Pattern ein Datum und ein anderes Format war, funktioniert es nicht.
'                                          Neues User-Datumsformat. Bis zu 10 Formate speicherbar und mittels %tu# abrufbar
'               30.10.2018 - 2.5.2 - ERS - Hotfix beim Ersetzen
'               15.11.2018 - 2.5.3 - ERS - Hotfox \t, \n, \r Am Anfang eines Patterns funktioniert jetzt
'               09.05.2019 - 2.6.0 - ERS - Neu q eingeführt. Analog zu s aber als SQL-String. ?sprintf("abc=%1$'#6q", "abc") => abc='###abc'
'               10.05.2019 - 2.6.1 - ERS - Fehler bei formatierung von Integer korrigiert
'               06.02.2020 - 2.7.0 - ERS - \\ am Ende durch \ ersetzen. Jeder \ der als String verwendet werden soll, muss mit einem \ maskiert werden
'                                          Null Parameter werden automatisch mit NZ() in empty umgewandelt  '$f'
'                                          ?sprintf("Null-Test: Zahl:'\\%f' Text:'\\%<s'", Null)    ->   Null-Test: Zahl:'\0' Text:'\'
'               13.02.2020 - 20701 - ERS - strReplace() durch replace() ersetzt. strReplace war von einer früheren Version drin
'
'Description  : Aus der PHP-Doku:
'               - An optional sign specifier that forces a sign (- or +) to be used on a number. By default, only the - sign is used on a number if it's negative.
'                 This specifier forces positive numbers to have the + sign attached as well, and was added in PHP 4.3.0.
'               - An optional padding specifier that says what character will be used for padding the results to the right string size. This may be a space character or a 0
'                 (zero character). The default is to pad with spaces. An alternate padding character can be specified by prefixing it with a single quote (')
'               - An optional alignment specifier that says if the result should be left-justified or right-justified. The default is right-justified; a - character
'                 here will make it left-justified.
'               - An optional number, a width specifier that says how many characters (minimum) this conversion should result in.
'               - An optional precision specifier in the form of a period (`.') followed by an optional decimal digit string that says how many decimal digits
'                 should be displayed for floating-point numbers. When using this specifier on a string, it acts as a cutoff point, setting a maximum character
'                 limit to the string.
'
'               A type specifier that says what type the argument data should be treated as. Possible types:
'                   % - a literal percent character. No argument is required.
'                   //b - the argument is treated as an integer, and presented as a binary number.
'                   c - the argument is treated as an integer, and presented as the character with that ASCII value.
'                   d - the argument is treated as an integer, and presented as a (signed) decimal number.
'                   e - the argument is treated as scientific notation (e.g. 1.2e+2). The precision specifier stands for the number of digits after the decimal point
'                   E - like %e but uses uppercase letter (e.g. 1.2E+2).
'                   u - the argument is treated as an integer, and presented as an unsigned decimal number.
'                   f - the argument is treated as a float, and presented as a floating-point number (locale aware).
'                   //F - the argument is treated as a float, and presented as a floating-point number (non-locale aware). Available since PHP 4.3.10 and PHP 5.0.3.
'                   g - shorter of %e and %f.
'                   G - shorter of %E and %f.
'                   o - the argument is treated as an integer, and presented as an octal number.
'                   s - the argument is treated as and presented as a string.
'                   q - the argument is treated as and presented as a string in sql-form: 'string'
'                   x - the argument is treated as an integer and presented as a hexadecimal number (with lowercase letters).
'                   X - the argument is treated as an integer and presented as a hexadecimal number (with uppercase letters).
'                   t, T - date/time   Prefix for date and time conversion characters. See Date/Time Conversions.
'                   S - date/time   Prefix for date and time conversion characters for MS Access SQL. See Date/Time Conversions.
'
'               Datumsformate:
'                   http://docs.oracle.com/javase/7/docs/api/java/util/Formatter.html
'                   f
'                       The following conversion characters are used for formatting times:
'                   H     Hour of the day for the 24-hour clock, formatted as two digits with a leading zero as necessary i.e. 00 - 23.
'                   I     Hour for the 12-hour clock, formatted as two digits with a leading zero as necessary, i.e. 01 - 12.
'                   k     Hour of the day for the 24-hour clock, i.e. 0 - 23.
'                   i     Hour for the 12-hour clock, i.e. 1 - 12.
'                   M     Minute within the hour formatted as two digits with a leading zero as necessary, i.e. 00 - 59.
'                   S     Seconds within the minute, formatted as two digits with a leading zero as necessary, i.e. 00 - 60 ("60" is a special value required to support leap seconds).

'                       The following conversion characters are used for formatting dates:
'                   B     Locale-specific full month name, e.g. "January", "February".
'                   b     Locale-specific abbreviated month name, e.g. "Jan", "Feb".
'                   A     Locale-specific full name of the day of the week, e.g. "Sunday", "Monday"
'                   a     Locale-specific short name of the day of the week, e.g. "Sun", "Mon"
'                   C     Four-digit year divided by 100, formatted as two digits with leading zero as necessary, i.e. 00 - 99
'                   Y     Year, formatted as at least four digits with leading zeros as necessary, e.g. 0092 equals 92 CE for the Gregorian calendar.
'                   y     Last two digits of the year, formatted with leading zeros as necessary, i.e. 00 - 99.
'                   j     Day of year, formatted as three digits with leading zeros as necessary, e.g. 001 - 366 for the Gregorian calendar.
'                   m     Month, formatted as two digits with leading zeros as necessary, i.e. 01 - 13.
'                   d     Day of month, formatted as two digits with leading zeros as necessary, i.e. 01 - 31
'                   e     Day of month, formatted as two digits, i.e. 1 - 31.

'                       The following conversion characters are used for formatting common date/time compositions.
'                   R     Time formatted for the 24-hour clock as "%tH:%tM"
'                   T     Time formatted for the 24-hour clock as "%tH:%tM:%tS".
'                   r     Time formatted for the 12-hour clock as "%tI:%tM:%tS %Tp". The location of the morning or afternoon marker ('%Tp') may be locale-dependent.
'                   D     Date formatted as "#%tm/%td/%ty#".
'                   t     DateTime formatted as "%tm/%td/%ty %tH:%tM:%tS".
'                   F     ISO 8601 complete date formatted as "%tY-%tm-%td".
'                   f     order by Datetie for sortable Date %tY-%t-%td_%H:%M:%S
'                   L     Date in Local "Long Date" Format
'                   l     Date in Local "Short Date" Format
'                   o     order by Date for sortable Date %tY%t%td
'                   O     order by Datetime for sortable Date %tY%t%td_%H%M%S
'                   u     User Format -> %u1. Set the Userformat with the public property printF_UserDefinedDateFormat(1) = "DD.MM"
'
'               Zusätzlich noch die Formatierungen analog http://www.freevbcode.com/ShowCode.asp?ID=5014
'               Um einen davon nicht zu parsen einfach mit einem \ marieren: '\\t' wird nicht zu Tabulator sondern zu '\t' geparst
'                   \n   Newline (Line Feed)
'                   \r   Carriage Return
'                   \t   Horizontal Tab
'-------------------------------------------------------------------------------

'-------------------------------------------------------------------------------
' -- ! 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 dazu keine Systemvariable
#Const isAccess = True

Option Explicit

'-----------------------------------------
'--- Public members
'-----------------------------------------
'Error: Zu wenige Werte wurden übergeben
Public Const ERR_INSUFFICIENT_PARAMS = vbObjectError - 10
'Es wird keine Zahl geliefert wo eine erwartet wird
Public Const ERR_NOT_NUMBER = vbObjectError - 11
'Das Format ist ungültig
Public Const ERR_INVALID_FORMAT = vbObjectError - 12

'-----------------------------------------
'--- Private members
'-----------------------------------------

'Die Auflistung der Submatches des geparsten Elements (Pattern D_ELEMENT_PATTERN)
Private Enum eSubElements
    emSubType1 = 0
    emCount
    emSubType2
    emType1
    emType2
    emFormat
    emIndex
    emPrefPos
End Enum

'Die Auflistung der Submatches des geparsten Formates (Pattern C_FORMAT_PATTERN)
Private Enum eSubFormat
    emWithSign = 0
    emFillZeroChar
    emFillChar
    emFillLength
    emInternalDecimalPlaces
End Enum

'Die Sammlung der Infos aus dem Pattern und der Typendefinition
Private Type tParts
    paramIndex                  As Integer
    types                       As String
    subTypeS                    As String
    count                       As Integer      'Ein Counter
    valueV                      As Variant      'Value als Variant, Also in Der Rohform aus dem Input
    values                      As String       'Formatierter Value als String
    format                      As String       'Das Format
    typeDef                     As String       'Typendefinition
End Type

'Infos aus dem Format
Private Type tFormat
    withSgn                     As Boolean      'Flag: das Vorzeigen immer angezeigt werden muss
    sgn                         As String       'Vorzeichen
    hasInternalDecimalPlaces    As Boolean      'Flag: hat Fixe nachkommastellen
    internalDecimalPlaces       As Integer      'Fixe Nachkommastellen
    fillChar                    As String       'Füllzeichen
    hasFillLength               As Boolean      'Flag: Hat fixe Vorkommalänge
    fillLength                  As Integer      'Fixe Vorkommalänge
End Type

Private Enum eTypeDef
    eString
    eNumber
    eDateTime
    eSpezial
End Enum

Private Enum sysLocale
    LOCALE_IFIRSTDAYOFWEEK = &H100C     'first day of week specifier 0=Mon, 6=Sun                 https://msdn.microsoft.com/en-us/library/windows/desktop/dd373771%28v=vs.85%29.aspx
    LOCALE_IFIRSTWEEKOFYEAR = &H100D    'first week of year specifier 0=direct, 1=Full, 2=4days   https://msdn.microsoft.com/en-us/library/windows/desktop/dd373772%28v=vs.85%29.aspx
    LOCALE_SSHORTDATE = &H1F            '31: short date format string
End Enum
  
Private Declare Function GetUserDefaultLCID Lib "kernel32" () As Long
Private Declare Function GetSystemDefaultLCID Lib "kernel32" () As Long
Private Declare Function getLocaleInfo Lib "kernel32" Alias "GetLocaleInfoA" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String, ByVal cchData As Long) As Long

Private userDateFormat(0 To 9) As String

'-----------------------------------------
'--- Public Methodes
'-----------------------------------------

'/**
' * Parse einen String mit Werten
' * @param  <String>        Zu formatierender String
' * @param  <Variant>*      die dazugehörigen Werte
' * @return <String>
' */
Public Function sPrintF(ByVal iFormatString As String, ParamArray iParams() As Variant) As String
On Error GoTo Err_Handler: Err.Source = "sPrintF"
    
    If UBound(iParams) = -1 Then
        sPrintF = replaceFormat(iFormatString)
    Else
        sPrintF = vsPrintF(iFormatString, CVar(iParams))
    End If

Exit_Handler:
On Error Resume Next
    Exit Function
Err_Handler:
    Call Err.Raise(Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext)
    Resume Exit_Handler
    Resume
End Function


'/**
' * Parse einen String mit den Werten als Array.
' * @param  <String>         Zu formatierender String
' * @param  Array<Variant>   die dazugehörigen Werte
' * @return <String>
' */
Public Function vsPrintF(ByVal iFormatString As String, ByRef iParams As Variant) As String
On Error GoTo Err_Handler: Err.Source = "vsPrintF"

    Dim params     As Variant: params = IIf(IsArray(iParams), iParams, Array(iParams))

    'Formatedefinitionen /t /n etc ausführen
    'Der String muss nachher umgedreht werden, da VBA object kein (?>!..) kennt
    vsPrintF = replaceFormat(iFormatString)

    'Wenn keine Parameters angegeben sind, dann beenden
    If UBound(params) = -1 Then Resume Exit_Handler

    'String parsen

'    vsPrintF = evalWithRx(rxDTElement, vsPrintF, params)
    vsPrintF = evalWithRx(rxElement, vsPrintF, params)

        'Maskierte \ zurücksetzen
    vsPrintF = replace(vsPrintF, "\\", "\")


Exit_Handler:
On Error Resume Next
    Exit Function
Err_Handler:
    Call Err.Raise(Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext)
    Resume Exit_Handler
    Resume
End Function

'-----------------------------------------
'--- Public Properties
'-----------------------------------------

'/**
' * Ein Userdefiniertes Datumsformat
' * @param  Integer     Nummer des Formates. 0-9 möglich
' * @return String      Datumsformat
' */
Public Property Get printF_UserDefinedDateFormat(Optional ByVal iNumber As Integer = 0) As String
    iNumber = IIf(iNumber > 9, 9, iNumber)
    iNumber = IIf(iNumber < 0, 0, iNumber)
    printF_UserDefinedDateFormat = IIf(userDateFormat(iNumber) = Empty, "Short Date", userDateFormat(iNumber))
End Property

Public Property Let printF_UserDefinedDateFormat(ByVal iNumber As Integer, ByVal iDateFormat As String)
    iNumber = IIf(iNumber > 9, 9, iNumber)
    iNumber = IIf(iNumber < 0, 0, iNumber)
    userDateFormat(iNumber) = iDateFormat
End Property

'-----------------------------------------
'--- Private Properties/Cache
'-----------------------------------------
'/**
' * object um die einzelnen Elemente aus dem Pattern zu extrahieren
' * 0: SubType
' * 1: Type
' * 2: Type
' * 3: Count
' * 4: Type
' * 5: Format
' * 6: Item Nummer
' * 7: Verweis auf vorhergehende Position
' * @return object
' */
Private Property Get rxElement() As Object
    Static rx As Object
    If rx Is Nothing Then Set rx = cRx("/(?:(?:([HIikLlMSLNpzZsQBbhAaCYyjmdeRTtrDFfPoO])|(\d)([u]))([tTS])|([sqcdfuoxXeEgG]))([\d-\.'#]*)(?:\$(\d+)|(<))?%(?!\\(?!\\))/gm")
    Set rxElement = rx
End Property

Private Property Get rxNonElement() As Object
    Static rx As Object
    If rx Is Nothing Then Set rx = cRx("/((?:(?:[HIikLlMSLNpzZsQBbhAaCYyjmdeRTtrDFfPoO]|\d[u])[tTS]|[sqcdfuoxXeEgG])[\d-\.'#]*(?:\$\d+|<)?%)(?:\\(?!\\))/gm")
    Set rxNonElement = rx
End Property


'Private Property Get rxElement() As Object
'    Static rx As Object
'    If rx Is Nothing Then Set rx = cRx("/()([scdfuoxXeEgG])([\d-\.'#]*)(?:\$(\d+)|(<)|)%(?!\\)/gm")
'    Set rxElement = rx
'End Property
'
'Private Property Get rxDTElement() As Object
'    Static rx As Object
'    If rx Is Nothing Then Set rx = cRx("/([HIikLlMSLNpzZsQBbhAaCYyjmdeRTrDFPoO])([tTS])([\d-\.'#]*)(?:\$(\d+)|(<)|)%(?!\\)/gm")
'    Set rxDTElement = rx
'End Property

'/**
' * object um die Formate zu analysieren
' * emWithSign = 0
' * emFillZeroChar
' * emFillChar
' * emFillLength
' * emInternalDecimalPlaces
' * @return object
' */
Private Property Get rxFormat() As Object
    Static rx As Object
    If rx Is Nothing Then Set rx = cRx("/([-+]?)(?:(0)|'(.)|)([1-9]\d*|)(?:\.([0-9]+)|)/gm")
    Set rxFormat = rx
End Property

'/**
' * Typendefinition
' * @return Dictionary
' */
Private Property Get typeDefs()
    Static pCacheTypeDefs As Object
    If pCacheTypeDefs Is Nothing Then
        Set pCacheTypeDefs = CreateObject("scripting.Dictionary")
        With pCacheTypeDefs
            .RemoveAll
    
            'Die verschiedenen Typendefinitionen laden
            .add "s", eString              's - the argument is treated as and presented as a string.
            .add "q", eString              'q - the argument is treated as and presented as a string.
            .add "d", eNumber              'd - the argument is treated as an integer, and presented as a (signed) decimal number.
            .add "f", eNumber              'f - the argument is treated as a float, and presented as a floating-point number (locale aware).
            .add "u", eNumber              'u - the argument is treated as an integer, and presented as an unsigned decimal number.
            .add "c", eSpezial             'c - the argument is treated as an integer, and presented as the character with that ASCII value.
            .add "o", eSpezial             'o - the argument is treated as an integer, and presented as an octal number.
            .add "x", eSpezial             'x - the argument is treated as an integer and presented as a hexadecimal number (with lowercase letters).
            .add "X", eSpezial             'X - the argument is treated as an integer and presented as a hexadecimal number (with uppercase letters).
            .add "e", eSpezial             'e - the argument is treated as scientific notation (e.g. 1.2e+2). The precision specifier stands for the number of digits after the decimal point
            .add "E", eSpezial             'E - like %e but uses uppercase letter (e.g. 1.2E+2).
            .add "g", eSpezial             'g - shorter of %e and %f.
            .add "G", eSpezial             'G - shorter of %E and %f.
            .add "t", eDateTime
            .add "T", eDateTime
            .add "S", eDateTime
        End With
    End If
    Set typeDefs = pCacheTypeDefs
End Property

'/**
' * die object um die Formatierungen (\t, \n etc) zu handeln
' * @return Dictionary(object => ReplaceString)
' */
Public Property Get formatDefs() As Object
    Static pCacheFormatDefs As Object
    If pCacheFormatDefs Is Nothing Then
        Set pCacheFormatDefs = CreateObject("scripting.Dictionary")
        pCacheFormatDefs.add cRx("/(.*[^\\]|^)\\n(.*)/m"), "$1" & vbLf & "$2"  '\n   Newline (Line Feed)
        pCacheFormatDefs.add cRx("/(.*[^\\]|^)\\r(.*)/m"), "$1" & vbCr & "$2"  '\r   Carriage Return
        pCacheFormatDefs.add cRx("/(.*[^\\]|^)\\t(.*)/m"), "$1" & vbTab & "$2" '\t   Horizontal Tab
    End If
    Set formatDefs = pCacheFormatDefs
End Property

'-----------------------------------------
'--- Private Methodes
'-----------------------------------------
'/**
' * Wertet den String anhand eines RegeExp aus
' * @param  RegExp
' * @param  String
' * @param  Array<Variant>
' * @return String
' */
Private Function evalWithRx(ByRef irx As Object, ByVal iString As String, ByRef iParams As Variant) As String
On Error GoTo Err_Handler: Err.Source = "evalWithRx"

    evalWithRx = StrReverse(iString)
    If Not irx.test(evalWithRx) Then GoTo Exit_Handler
    
    Dim matches As Object: Set matches = irx.execute(evalWithRx)
    Dim lEof As Long: lEof = matches.count - 1
    Dim parts() As tParts: ReDim parts(lEof)
    Dim delta As Long
    Dim i  As Integer: For i = lEof To 0 Step -1
        Dim position As Integer:    position = (lEof - i)
        Dim ma As Object:           Set ma = matches.item(i)
        With parts(i)
            'Werte aus dem Pattern auslesen
            'Der Index aus dem Pattern oder die Position im String
            'Falls es sich um ein < Handelt, den vorherigen paramIndex verwenden, ausser es ist der Erste
            If ma.subMatches(emPrefPos) = "<" And i < lEof Then
                .paramIndex = parts(i + 1).paramIndex
                delta = delta - 1
            'Keine eindeutige Position angegeben
            ElseIf ma.subMatches(emIndex) = Empty Then
                .paramIndex = position + delta
            'Position aus dem Pattern übernehmen
            Else
                .paramIndex = ma.subMatches(emIndex) - 1
            End If
            'Formatdefinitionen aus dem Pattern
            .format = StrReverse(NZ(ma.subMatches(emFormat)))
            .types = ma.subMatches(emType1) & ma.subMatches(emType2)
            .subTypeS = ma.subMatches(emSubType1) & ma.subMatches(emSubType2)
            .count = CInt(NZ(ma.subMatches(emCount)))
            'Werte der Typendefinitione übernehmen
            .typeDef = typeDefs(.types)
            'Prüfen ob zu dem ermittelten Index auch ein Parameterwert exisitiert
            If .paramIndex > UBound(iParams) Then Call Err.Raise(ERR_INSUFFICIENT_PARAMS, , "Not enough values für (v)sprintf(). ")
            'unformatierten Wert aus den Parametern auslsen
            .valueV = NZ(iParams(.paramIndex))
            'Parsen und Formatieren.
            Select Case .typeDef
                Case eSpezial:     Call parseSpezial(parts(i))
                Case eDateTime:    Call parseDateTime(parts(i))
                Case eNumber:      Call parseNumber(parts(i))
                Case eString:      Call parseString(parts(i))
            End Select
        End With
    Next i
    
    Dim rx As Object: Set rx = cRx("/" & irx.pattern & "/m")
    i = 0
    Do While rx.test(evalWithRx)
        evalWithRx = rx.replace(evalWithRx, StrReverse(parts(i).values))
        i = i + 1
    Loop

    'Maskierung bei maskierten Pattern entfernen
    evalWithRx = rxNonElement.replace(evalWithRx, "$1")
    
Exit_Handler:
On Error Resume Next
    evalWithRx = StrReverse(evalWithRx)
    Set ma = Nothing
    Set matches = Nothing
    Exit Function
Err_Handler:
    Call Err.Raise(Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext)
    Resume Exit_Handler
    Resume
End Function

'/**
' * Parst Formatierungen wie \n, \t etc
' * @param  <String>        Zu formatierender String
' * @return <String>
' */
Private Function replaceFormat(ByVal iFormatString As String) As String
On Error GoTo Err_Handler: Err.Source = "replaceFormat"

    replaceFormat = iFormatString
    Dim rx As Variant: For Each rx In formatDefs
        Do While rx.test(replaceFormat)
            replaceFormat = rx.replace(replaceFormat, formatDefs(rx))
        Loop
    Next

Exit_Handler:
On Error Resume Next
    Exit Function
Err_Handler:
    Call Err.Raise(Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext)
    Resume Exit_Handler
    Resume
End Function

'/*
' * Nur das preFormat wird ausgeführt. Der format-Part des Patterns wird ignoriert
' * @param <tParts>
' */
Private Sub parseSpezial(ByRef ioParts As tParts)
On Error GoTo Err_Handler: Err.Source = "parseSpezial"
    With ioParts
        Select Case .types
            Case "c": .valueV = Chr(CInt(.valueV))
            Case "o": .valueV = Oct(.valueV)
            Case "x": .valueV = LCase(Hex(.valueV))
            Case "X": .valueV = UCase(Hex(.valueV))
            Case "e": .valueV = LCase(format(.valueV, "Scientific"))
            Case "E": .valueV = UCase(format(.valueV, "Scientific"))
            Case "g": .valueV = IIf(Len(".ValueV") <= Len(format(.valueV, "Scientific")), CDbl(.valueV), LCase(format(.valueV, "Scientific")))
            Case "G": .valueV = IIf(Len(".ValueV") <= Len(format(.valueV, "Scientific")), CDbl(.valueV), UCase(format(.valueV, "Scientific")))
        End Select
    End With

Exit_Handler:
On Error Resume Next
    Exit Sub
Err_Handler:
    Call Err.Raise(Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext)
    Resume Exit_Handler
    Resume
End Sub

'/*
' * Parse a Number
' * @param <tParts>
' */
Private Sub parseNumber(ByRef ioParts As tParts)
On Error GoTo Err_Handler: Err.Source = "parseNumber"

    With ioParts
        If Not IsNumeric(.valueV) Then Call Err.Raise(ERR_NOT_NUMBER, , "Parameter is not a Number")
        Select Case .types
            Case "d":   .valueV = CLng(.valueV)
            Case "f":   .valueV = CDbl(.valueV)
            Case "u":   .valueV = Abs(CInt(.valueV))
        End Select
        .values = parseNumberFormat(.format, .valueV)
    End With

Exit_Handler:
On Error Resume Next
    Exit Sub
Err_Handler:
    Call Err.Raise(Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext)
    Resume Exit_Handler
    Resume
End Sub

'/**
' * Formatiert eine Nummer
' * @param  String
' * @param  Variant
' * @return String
' */
Private Function parseNumberFormat(ByVal iFormat As String, ByVal iValueV As Variant) As String
On Error GoTo Err_Handler: Err.Source = "parseNumberFormat"
    
    parseNumberFormat = CStr(iValueV)
    If iFormat = vbNullString Then Exit Function

    'Formatdetails auselsen
    Dim fd As tFormat:  fd = parseFormat(iFormat, 0)

    Dim formats As String
    'Mit 0 auffüllen
    formats = "0"
    If fd.hasFillLength Then formats = str_repeat("0", fd.fillLength)
    'Dezmalzeichen
    If fd.hasInternalDecimalPlaces Then
        If fd.internalDecimalPlaces > 0 Then formats = formats & "." & str_repeat("0", fd.internalDecimalPlaces)
    Else
        If iValueV <> Fix(iValueV) Then
            formats = formats & "." & str_repeat("#", Len(iValueV - Fix(iValueV)))
        End If
    End If
    'Vorzeichen
    If fd.withSgn Then formats = "+" & formats & ";-" & formats

    parseNumberFormat = format(iValueV, formats)

Exit_Handler:
On Error Resume Next
    Exit Function
Err_Handler:
    Call Err.Raise(Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext)
    Resume Exit_Handler
    Resume
End Function

'/*
' * Parse a String
' * @param <tParts>
' */
Private Sub parseString(ByRef ioParts As tParts)
On Error GoTo Err_Handler: Err.Source = "parseString"
    
    With ioParts

'ERS: 08.12.2014: Keine Ahnung warum ' maskiert werden sollten
        ' '-Zeichen im Text markieren
'        .valueV = Replace(CStr(.valueV), "'", "''")
        'Wenn kein Format definiert ist, einfach die Variable un
        .values = CStr(.valueV)
        If Not .format = vbNullString Then

            'Formatdetails auselsen. Die Items von fd haben die Namen von der Nummerformatierung
            Dim fd As tFormat: fd = parseFormat(.format, " ")

            'Wenn ien Vorzeichen gesetzt ist, das ganez Rechtbündig nehmen
            'An optional alignment specifier that says if the result should be left-justified or right-justified. The default is right-justified; a - character
            'here will make it left-justified.
            If fd.sgn = "-" Then
                If fd.hasFillLength Then
                    .values = rPad(.values, fd.fillChar, fd.fillLength)
                End If
                If fd.hasInternalDecimalPlaces Then
                    .values = Right(.values, fd.internalDecimalPlaces)
                End If
            Else
                If fd.hasFillLength Then
                    .values = lPad(.values, fd.fillChar, fd.fillLength)
                End If
                If fd.hasInternalDecimalPlaces Then
                    .values = Left(.values, fd.internalDecimalPlaces)
                End If
            End If

        End If
        If .types = "q" Then .values = "'" & .values & "'"
    End With

Exit_Handler:
On Error Resume Next
    Exit Sub
Err_Handler:
    Call Err.Raise(Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext)
    Resume Exit_Handler
    Resume
End Sub



'  The following conversion characters are used for formatting times:
' 'H'     Hour of the day for the 24-hour clock, formatted as two digits with a leading zero as necessary i.e. 00 - 23.
' 'I'     Hour for the 12-hour clock, formatted as two digits with a leading zero as necessary, i.e. 01 - 12.
' 'k'     Hour of the day for the 24-hour clock, i.e. 0 - 23.
' 'i'     Hour for the 12-hour clock, i.e. 1 - 12.
' 'M'     Minute within the hour formatted as two digits with a leading zero as necessary, i.e. 00 - 59.
' 'S'     Seconds within the minute, formatted as two digits with a leading zero as necessary, i.e. 00 - 60 ("60" is a special value required to support leap seconds).
'- 'L'     Millisecond within the second formatted as three digits with leading zeros as necessary, i.e. 000 - 999.
'- 'N'     Nanosecond within the second, formatted as nine digits with leading zeros as necessary, i.e. 000000000 - 999999999.
'- 'p'     Locale-specific morning or afternoon marker in lower case, e.g."am" or "pm". Use of the conversion prefix 'T' forces this output to upper case.
'- 'z'     RFC 822 style numeric time zone offset from GMT, e.g. -0800. This value will be adjusted as necessary for Daylight Saving Time. For long, Long, and Date the time zone used is the default time zone for this instance of the Java virtual machine.
'- 'Z'     A string representing the abbreviation for the time zone. This value will be adjusted as necessary for Daylight Saving Time. For long, Long, and Date the time zone used is the default time zone for this instance of the Java virtual machine. The Formatter's locale will supersede the locale of the argument (if any).
'- 's'     Seconds since the beginning of the epoch starting at 1 January 1970 00:00:00 UTC, i.e. Long.MIN_VALUE/1000 to Long.MAX_VALUE/1000.
'- 'Q'     Milliseconds since the beginning of the epoch starting at 1 January 1970 00:00:00 UTC, i.e. Long.MIN_VALUE to Long.MAX_VALUE.
'
' The following conversion characters are used for formatting dates:
' 'B'     Locale-specific full month name, e.g. "January", "February".
' 'b'     Locale-specific abbreviated month name, e.g. "Jan", "Feb".
'- 'h'     Same as 'b'.
' 'A'     Locale-specific full name of the day of the week, e.g. "Sunday", "Monday"
' 'a'     Locale-specific short name of the day of the week, e.g. "Sun", "Mon"
' 'C'     Four-digit year divided by 100, formatted as two digits with leading zero as necessary, i.e. 00 - 99
' 'Y'     Year, formatted as at least four digits with leading zeros as necessary, e.g. 0092 equals 92 CE for the Gregorian calendar.
' 'y'     Last two digits of the year, formatted with leading zeros as necessary, i.e. 00 - 99.
' 'j'     Day of year, formatted as three digits with leading zeros as necessary, e.g. 001 - 366 for the Gregorian calendar.
' 'm'     Month, formatted as two digits with leading zeros as necessary, i.e. 01 - 13.
' 'd'     Day of month, formatted as two digits with leading zeros as necessary, i.e. 01 - 31
' 'e'     Day of month, formatted as two digits, i.e. 1 - 31.
'
' The following conversion characters are used for formatting common date/time compositions.
' 'R'     Time formatted for the 24-hour clock as "%tH:%tM"
' 'T'     Time formatted for the 24-hour clock as "%tH:%tM:%tS".
' 'r'     Time formatted for the 12-hour clock as "%tI:%tM:%tS %Tp". The location of the morning or afternoon marker ('%Tp') may be locale-dependent.
' 'D'     Date formatted as "%tm/%td/%ty".
' 't'     DateTime formatted as "%tm/%td/%ty %tH:%tM:%tS".
' 'F'     ISO 8601 complete date formatted as "%tY-%tm-%td".
' 'f'     order by Datetie for sortable Date %tY-%t-%td_%H:%M:%S
' 'L'      Date in Local "Long Date" Format
' 'l'      Date in Local "Short Date" Format
'- 'c'     Date and time formatted as "%ta %tb %td %tT %tZ %tY", e.g. "Sun Jul 20 16:17:00 EDT 1969".
' 'o'     order by Date for sortable Date %tY%t%td
' 'O'     order by Datetie for sortable Date %tY%t%td_%H%M%S
' 'u'     User Format -> %u0


'/*
' * Parse a String
' * @param <tParts>
' */
Private Sub parseDateTime(ByRef ioParts As tParts)
On Error GoTo Err_Handler: Err.Source = "parseDateTime"

    Select Case ioParts.subTypeS
        Case "H":   ioParts.values = format(ioParts.valueV, "HH")
        Case "I":   ioParts.values = format(ioParts.valueV, "HHAMPM")
        Case "k":   ioParts.values = format(ioParts.valueV, "H")
        Case "i":   ioParts.values = format(ioParts.valueV, "HAMPM")
        Case "M":   ioParts.values = format(ioParts.valueV, "NN")
        Case "S":   ioParts.values = format(ioParts.valueV, "SS")
        Case "P":   ioParts.values = format(ioParts.valueV, "AM/PM")
        Case "B":   ioParts.values = format(ioParts.valueV, "MMMM")
        Case "b":   ioParts.values = format(ioParts.valueV, "MMM")
        Case "A":   ioParts.values = format(ioParts.valueV, "DDDD")
        Case "a":   ioParts.values = format(ioParts.valueV, "DDD")
        Case "C":   ioParts.values = CStr(year(ioParts.valueV) \ 100)
        Case "Y":   ioParts.values = format(ioParts.valueV, "YYYY")
        Case "Y":   ioParts.values = format(ioParts.valueV, "YY")
        Case "j":   ioParts.values = format(format(ioParts.valueV, "Y"), "000")
        Case "m":   ioParts.values = format(ioParts.valueV, "MM")
        Case "d":   ioParts.values = format(ioParts.valueV, "DD")
        Case "e":   ioParts.values = format(ioParts.valueV, "D")
        Case "R":   ioParts.values = format(ioParts.valueV, "HH:NN")
        Case "T":   ioParts.values = format(ioParts.valueV, "HH:NN:SS")
        Case "r":   ioParts.values = format(ioParts.valueV, "HH:NN:SS AM/PM")
        Case "D":   ioParts.values = format(ioParts.valueV, "MM\/DD\/YYYY")
        Case "t":   ioParts.values = format(ioParts.valueV, "MM\/DD\/YYYY HH:NN:SS")
        Case "F":   ioParts.values = format(ioParts.valueV, "YYYY-MM-DD")
        Case "f":   ioParts.values = format(ioParts.valueV, "YYYY-MM-DD HH:NN:SS")
        Case "L":   ioParts.values = format(ioParts.valueV, "Long Date")
        Case "l":   ioParts.values = format(ioParts.valueV, "Short Date")
        Case "O":   ioParts.values = format(ioParts.valueV, "YYYYMMDD_HHNNSS")
        Case "o":   ioParts.values = format(ioParts.valueV, "YYYYMMDD")
        Case "u":   ioParts.values = format(ioParts.valueV, printF_UserDefinedDateFormat)
    End Select
  
    'Spezialfall SQL
    If ioParts.types = "S" Then
        Select Case ioParts.subTypeS
            Case "R", "T", "t", "D", "F", "f", "r":  ioParts.values = "#" & ioParts.values & "#"
            Case "B", "b", "A", "a":                      ioParts.values = "'" & ioParts.values & "'"
        End Select
    End If
    
Exit_Handler:
On Error Resume Next
    Exit Sub
Err_Handler:
    Call Err.Raise(Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext)
    Resume Exit_Handler
    Resume
End Sub

'/**
' * Parst den Format-Teil des Patterns
' * @param  <String>        Formatteil
' * @param  <Variant>       Standart-Füllzeichen
' * @return <tFormat>
' */
Private Function parseFormat(ByVal iFormat As String, ByVal iDefaultFillChar As Variant) As tFormat
On Error GoTo Err_Handler: Err.Source = "parseFormat"

    If Not rxFormat.test(iFormat) Then Call Err.Raise(ERR_INVALID_FORMAT, , "Wrong Format '" & iFormat & "'")
    
    'Format parsen
    Dim matches As Object: Set matches = rxFormat.execute(iFormat)

    Dim subMatches  As Object: Set subMatches = matches.item(0).subMatches

    'Die einzelnen Teile auslesen und auswerten
    With parseFormat
        'Füllzeichen ermitteln
        .fillChar = subMatches(emFillZeroChar)
        If .fillChar = Empty Then .fillChar = subMatches(emFillChar)
        If .fillChar = Empty Then .fillChar = iDefaultFillChar

        'Füllänge
        .hasFillLength = subMatches(emFillLength) <> Empty
        If .hasFillLength Then .fillLength = CInt(subMatches(emFillLength))

        'Nachkommastellen
        .hasInternalDecimalPlaces = subMatches(emInternalDecimalPlaces) <> Empty
        If .hasInternalDecimalPlaces Then .internalDecimalPlaces = CInt(subMatches(emInternalDecimalPlaces))

        'Vorzeichen (bei String, Links-Rechts Bündig)
        .withSgn = subMatches(emWithSign) <> Empty
        'Das Vorzeichen selber wird so nur beim String verwendet
        .sgn = IIf(.withSgn, subMatches(emWithSign), "+")
    End With

Exit_Handler:
On Error Resume Next
    Set subMatches = Nothing
    Set matches = Nothing

    Exit Function
Err_Handler:
    Call Err.Raise(Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext)
    Resume Exit_Handler
    Resume
End Function

'-----------------------------------------
'--- Verwendete allgemeine Funktionen
'-----------------------------------------

'-----------------------------------------
' cDict V 2.1.0
'-----------------------------------------

'/**
' * Wandelt verschiedene Formate in ein Dictionary um
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cdict
' * @param  ParamArray
' * @return Dictionary
' */
Private Function cDict(ParamArray iItems() As Variant) As Object
    Set cDict = CreateObject("scripting.Dictionary")
    Dim items() As Variant: items = CVar(iItems)
    Dim i As Integer, key As Variant, value As Variant
    Dim isList As Boolean
    
    If UBound(items) = -1 Then Exit Function

    'Prüfen ob 2 Parametetrs übergeben wurden
    If UBound(items) = 1 Then
        'Beide Parametrer sind Arrays -> Combine: Erster Array Keys, 2ter Values
        If IsArray(items(0)) And IsArray(items(1)) Then
            key = items(0):         value = items(1)
            Dim delta As Long:      delta = LBound(key) - LBound(value)
            ReDim Preserve value(LBound(value) To UBound(key) + delta)
            For i = LBound(key) To UBound(key)
                If Not cDict.exists(key(i)) Then cDict.add key(i), value(i + delta)
            Next i
            Exit Function
        End If
    End If
    
    'Alle Items durchackern
    For i = 0 To UBound(items)
        Dim item As Variant: ref item, items(i)
        'Dictionary
        If Not isList And TypeName(item) = "Dictionary" Then
            For Each key In items(i).keys
                If Not cDict.exists(key) Then cDict.add key, item.item(key)
            Next key
        'einsamer Array
        ElseIf Not isList And IsArray(item) Then
            For key = LBound(item) To UBound(item)
                If Not cDict.exists(key) Then cDict.add key, item(key)
            Next key
        'SetString
        ElseIf Not isList And Not IsArray(item) And Not IsObject(item) Then
            If rxSetString.test(StrReverse(item)) Then
                Dim mc As Object: Set mc = rxSetString.execute(StrReverse(item))
                Dim k As Integer: For k = mc.count - 1 To 0 Step -1
                    Dim m As Object: Set m = mc(k)
                    key = StrReverse(firstValue(m.subMatches(6), m.subMatches(5), m.subMatches(3)))
                    value = StrReverse(firstValue(m.subMatches(2), m.subMatches(1)))
                    Select Case m.subMatches(0)
                        Case "#":   value = dateValue(value)  'eval("#" & value & "#")
                        Case Empty: value = CDec(value)
                        Case Else:  value = cRx("/\\(['""])/g").replace(value, "$1")
                    End Select
                    If Not cDict.exists(key) Then cDict.add key, value
                Next k
            Else
                GoTo default        'Zuerst wollte ich diesen GoTo nicht haben. Aber StrReverse() wirft ein Fehler wenn ein Objekt übergeben wird. Darum konnte der Test nicht im ElseIf durchgeführt werden.
            End If
        'Alles andere geht in ein WertePaar.
        ElseIf i = 0 Or isList Then
default:
            If i Mod 2 = 0 Then
                key = item
            Else
                If Not cDict.exists(key) Then cDict.add key, item
            End If
            isList = True
        End If
    Next i
    'Falls es sich um eine nicht abgeschlossene Liste handelt
    If isList And i Mod 2 <> 0 Then
        If Not cDict.exists(key) Then cDict.add key, Empty
    End If
End Function

'-------------------------------------------------------------------------------
'-- Private methodes / properties for cDict()
'-------------------------------------------------------------------------------
'/**
' * Gibt den ersten Wert zurück, der nicht Nothing, Empty oder Null ist
' * @param  ParamArray
' * @return Variant
' */
Private Function firstValue(ParamArray items() As Variant) As Variant
    For Each firstValue In items
        If IsObject(firstValue) Then
            If Not firstValue Is Nothing Then Exit For
        Else
            If Not IsNull(firstValue) And Not firstValue = Empty Then Exit For
        End If
    Next
End Function

'/**
' * Gibt eine Refernez auf den Wert zurück
' * @param  Variant     Variable, di abgefüllt werden soll
' * @param  Variant     Value
' */
Private Sub ref(ByRef oItem As Variant, Optional ByRef iItem As Variant)
    If IsMissing(iItem) Then
        oItem = Empty
    ElseIf IsObject(iItem) Then
        Set oItem = iItem
    Else
        oItem = iItem
    End If
End Sub

'/**
' * Handelt den object-Cache um ein Set-String zu zerlegen
' * @return object
' */
Private Property Get rxSetString() As Object
    Static rxCachedSetString As Object
    If rxCachedSetString Is Nothing Then
        Set rxCachedSetString = CreateObject("VBScript.RegExp")
        rxCachedSetString.Global = True
        rxCachedSetString.pattern = "(?:(['""#])(?!\\)(.+?)\1(?!\\)|([0-9\.]+?))\s*(?:>=|[:=])\s*(?:\]([^\[]+)\[|(['""])(?!\\)(.+?)\5(?!\\)|(\w+))"
    End If
    Set rxSetString = rxCachedSetString
End Property

'-------------------------------------------------------------------------------
'-- cRx()
'-------------------------------------------------------------------------------

'/**
' * Dies ist die Minimalversion von cRegExp
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cregexp#abgespeckte_version
' * mögliche Delemiter: @&!/~#=\|
' * mögliche Modifiers: g (Global), i (IgnoreCode, m (Mulitline)
' *
' * @example    myRx = cRx("/([a]{2,})/i") 'Finde alle folgen von a. Flag:IgnoreCase
' * @version    2.1.0 (01.12.2014)
' * @param      String      Pattern mit Delimiter und Modifier analog zu PHP
' * @return     Object      object-Object
' */
Private Function cRx(ByVal iPattern As String) As Object
    Static rxP As Object:       Set cRx = CreateObject("VBScript.RegExp")
    If rxP Is Nothing Then:     Set rxP = CreateObject("VBScript.RegExp"): rxP.pattern = "^([@&!/~#=\|])?(.*)\1(?:([Ii])|([Gg])|([Mm]))*$"
    Dim sm As Object:           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

'http://support.microsoft.com/kb/96458
 '=====================================================================
   'The following function will left pad a string with a specified
   'character. It accepts a base string which is to be left padded with
   'characters, a character to be used as the pad character, and a
   'length which specifies the total length of the padded result.
 '=====================================================================
Private Function lPad(ByVal MyValue$, ByVal MyPadCharacter$, ByVal MyPaddedLength%)
Dim x As Integer
   Dim PadLength As Integer

      PadLength = MyPaddedLength - Len(MyValue)
      Dim padString As String
      For x = 1 To PadLength
         padString = padString & MyPadCharacter
      Next
      lPad = padString + MyValue

End Function
 '=====================================================================
   'The following function will right pad a string with a specified
   'character. It accepts a base string which is to be right padded with
   'characters, a character to be used as the pad character, and a
   'length which specifies the total length of the padded result.
 '=====================================================================
Private Function rPad(ByVal MyValue$, ByVal MyPadCharacter$, ByVal MyPaddedLength%)
Dim x As Integer
   Dim PadLength As Integer

      PadLength = MyPaddedLength - Len(MyValue)
      Dim padString As String
      For x = 1 To PadLength
         padString = MyPadCharacter & padString
      Next
      rPad = MyValue + padString

End Function

'/**
' * Wiederholt einen String
' * http://wiki.yaslaw.info/wikka/vbvbaStringFunctions
' * @param  String   zu wiederholender String
' * @param  Integer  Anzahl weiderholungen
' * @return String   Resultat
' */
Private Function str_repeat(ByVal str As String, ByVal multiplier As Integer) As String
    Dim i As Integer

    For i = 1 To multiplier
        str_repeat = str_repeat & str
    Next i
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