Attribute VB_Name = "lib_json"
'-------------------------------------------------------------------------------
'File         : lib_json.bas
'               Copyright mpl by ERB software
'               All rights reserved
'               http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/json
'Environment  : VBA 2010+: getestet mit MS Access 2010 & MS Excel 2010
'Version      : 1.4.0
'Name         : json
'Author       : Stefan Erb (ERS)
'History      : 19.02.2014 - ERS - Creation
'               ...
'               17.07.2014 - ERS - Prefix InternalArrayPrefix (#A oder #C) hinzugefügt um bei [] automatisch mitzugeben ob es sich um eine Collection oder ein Array handelt
'                                  Achtung! Sollte nur engestellt werden, wenn der JSON-String wieder mit dieser Lib zu einem Objekt gaprst werden soll
'               13.10.2014 - ERS - Cache auf Dictionary und Properties umgestellt, replaceA auf strReplace umgestellt sowie div. weitere Umstellungen
'http://de.wikipedia.org/wiki/JavaScript_Object_Notation
'-------------------------------------------------------------------------------
Option Explicit

'-------------------------------------------------------------------------------
' Public Members
'-------------------------------------------------------------------------------
'/**
' * Einstellungen, ob [...] in ein Array oder in eine Collection geschrieben werden soll
' */
Public Enum jsonDecodeParams
    jrtCollection = 2 ^ 1   'Als Collection
    jrtArray = 2 ^ 2        'Als Array
    jrtDictionary = 2 ^ 3 'Als Dictionary
    jrtDefault = jrtCollection
    jrtEmptyList = 2 ^ 5  'Angabe, ob bei einem Leeren String eine Collection/Array/Dictionary zurückgegeben werden soll
End Enum

'/**
' * Einstellung, ob Strings im JSON in ' oder in " gefasst werden sollen
' */
Public Enum jsonEncodeParams
    jqmDoubleQuote = 2 ^ 1        'Umfasst die Values mit einem "
    jqmSingleQuote = 2 ^ 2        'Umfasst die Values mit einem '
    jqmForceObject = 2 ^ 3        'Wandelt Arrays in Objekte
    jqmInternalArrayPrefix = 2 ^ 4  'Der JSON-String wird mit eigenen Prefixen bei Array und Collection mitgeliefert
    jqmDefault = jqmDoubleQuote
End Enum

Public Const JSON_ERROR_INVALID_INPUT = vbObjectError + 1

'-------------------------------------------------------------------------------
' Private Members
'-------------------------------------------------------------------------------
'Datums-Format nach ISO 8601
Private Const C_DATE_F = "YYYY-MM-DD\THH:NN:SS"
'Format für ein SubObject-Platzhalter: SubObject Nr12: &##012;
Private Const C_PARSE_PLACEHOLDER_F = "\&\#\#000\;"
'Unicode eines \
Private Const C_UNICODE_BACKSLASH = "\u005C"
Private Const C_UNICODE_SINGLE_QUOTES = "\u0022;"
Private Const C_UNICODE_DOUBLE_QUOTES = "\u0027;"

'/**
' * Wird für die rx_ Funktionen verwendet
' * Setzte die Flags für das RegExp Object
' */
Private Enum rxFlagsEnum
    rxnone = 2 ^ 0          'Value 1
    rxglobal = 2 ^ 1        'Value 2
    rxIgnorCase = 2 ^ 2     'Value 4
    rxMultiline = 2 ^ 3     'Value 8
End Enum

Private Enum arrFlags
    flRx = 0
    flReplace = 1
    flType = 2
End Enum
'-------------------------------------------------------------------------------
'-- Private members for cDict()
'-------------------------------------------------------------------------------
Private rxCachedSetString As Object

'-------------------------------------------------------------------------------
' Private Cache
'-------------------------------------------------------------------------------

'/**
' * Lokaler Cache
' */
Private pCache As Dictionary
Private strings() As String

'-------------------------------------------------------------------------------
' Public Aliase
'-------------------------------------------------------------------------------
'/**
' * Alias zu json()
' */
'Public Function obj2json(ByRef iObj As Variant, Optional ByVal iEncodeParams As jsonEncodeParams = jqmDefault) As String
'    obj2json = json(iObj, iEncodeParams)
'End Function

'/**
' * Alias zu parse
' */
'Public Function json2obj(ByVal iString As Variant, Optional ByVal iDecodeParams As jsonDecodeParams = jrtDefault, Optional ByRef oObj As Variant) As Variant
'    Call parse(iString, iDecodeParams, oObj)
'    If IsObject(oObj) Then Set json2obj = oObj Else json2obj = oObj
'End Function

'-------------------------------------------------------------------------------
' Object to JSON
'-------------------------------------------------------------------------------
'/**
' * Erstellt aus Directories, Collections und Arrays einen JSON-String
' * @param  Objekt
' * @param  jsonEncodeParams      Angabe über die Art der Anführungszeichen im JSON-String
' * @return String
' */
Public Function obj2json(ByRef iObj As Variant, Optional ByVal iEncodeParams As jsonEncodeParams = jqmDefault) As String
    If Not (IsArray(iObj) Or TypeName(iObj) = "Collection" Or TypeName(iObj) = "Dictionary") Then
        Err.Raise JSON_ERROR_INVALID_INPUT, "json", "Input is not a array or Collection or Dictionary"
    End If
    obj2json = jsonRekursive(iObj, iEncodeParams)
End Function

'/**
' * Interner Stringersteller
' * @param  Objekt
' * @param  jsonEncodeParams      Angabe über die Art der Anführungszeichen im JSON-String
' * @return String
' */
Private Function jsonRekursive(ByRef iObj As Variant, ByVal iEncodeParams As jsonEncodeParams) As String
    'Array
    If IsArray(iObj) Then
        jsonRekursive = jsonArray(iObj, iEncodeParams)
    'Collection
    ElseIf TypeName(iObj) = "Collection" Then
        jsonRekursive = jsonCollection(iObj, iEncodeParams)
    'Dictionary
    ElseIf TypeName(iObj) = "Dictionary" Then
        jsonRekursive = jsonDict(iObj, iEncodeParams)
    '[Key:]Value
    Else
        jsonRekursive = jsonValue(iObj, iEncodeParams)
    End If
End Function

'/**
' * get JSON-String from Collection
' * @param  Collection
' * @param  jsonEncodeParams      Angabe über die Art der Anführungszeichen im JSON-String
' * @return String                  JSON-String
' */
Private Function jsonCollection(ByRef iCollection As Variant, ByVal iEncodeParams As jsonEncodeParams) As String
    Dim arr() As Variant:   ReDim arr(1 To iCollection.count)
    Dim i As Long: For i = 1 To iCollection.count
        If IsObject(iCollection(i)) Then Set arr(i) = iCollection(i) Else arr(i) = iCollection(i)
    Next i

    jsonCollection = jsonArray(arr, iEncodeParams)
    If (iEncodeParams And jqmInternalArrayPrefix) Then
        jsonCollection = "#C" & Mid(jsonCollection, 3)
    End If
    
End Function

'/**
' * get JSON-String from Array
' * @param  Array
' * @param  jsonEncodeParams      Angabe über die Art der Anführungszeichen im JSON-String
' * @return String                  JSON-String
' */
Private Function jsonArray(ByRef iArray As Variant, ByVal iEncodeParams As jsonEncodeParams) As String
    Dim i As Long: For i = LBound(iArray) To UBound(iArray)
        iArray(i) = jsonRekursive(iArray(i), iEncodeParams)
    Next i

    jsonArray = "[" & Join(iArray, ",") & "]"
    If iEncodeParams And jqmInternalArrayPrefix Then jsonArray = "#A" & jsonArray
End Function

'/**
' * get JSON-String from Dictionary
' * @param  Dictionary
' * @param  jsonEncodeParams      Angabe über die Art der Anführungszeichen im JSON-String
' * @return String                  JSON-String
' */
Private Function jsonDict(ByRef iDict As Variant, ByVal iEncodeParams As jsonEncodeParams) As String
    Dim parts()     As String:      ReDim parts(iDict.count - 1)
    Dim keys()      As Variant:     keys = iDict.keys
    Dim items()     As Variant:     items = iDict.items

    Dim i As Long: For i = 0 To iDict.count - 1
        parts(i) = jsonValue(keys(i), iEncodeParams) & ":" & jsonRekursive(items(i), iEncodeParams)
    Next i
    jsonDict = "{" & Join(parts, ",") & "}"
End Function

'/**
' * Maskiert die Items und handelt die Spezialwerte
' * http://de.wikipedia.org/wiki/JavaScript_Object_Notation
' * @param  String
' * @param  jsonEncodeParams      Angabe über die Art der Anführungszeichen im JSON-String
' * @return String                  JSON-String
' */
Private Function jsonValue(ByVal iVar As Variant, ByVal iEncodeParams As jsonEncodeParams) As String
    Dim qm  As String:      qm = IIf(iEncodeParams = jqmDoubleQuote, """", "'")

    'Null
    If IsNull(iVar) Then                    'Null-Werte als null zurückgeben
        jsonValue = "null"
    'Boolean
    ElseIf TypeName(iVar) = "Boolean" Then  'Boolen als true/false ausgeben
        jsonValue = LCase(CBool(iVar))
    'Date
    ElseIf IsDate(iVar) Then                'Datum
        jsonValue = qm & format(iVar, C_DATE_F) & qm
    'Char
    ElseIf Not IsNumeric(iVar) Then         'Texte als "t\\ext" ausgeben
        '\ als unicode speichern: \u005C
        jsonValue = Replace(iVar, "\", C_UNICODE_BACKSLASH)
        'Spezialcharakters escapen (IIF(isNull()..) Anstelle von NZ für MS Excel
        jsonValue = strReplace(IIf(IsNull(jsonValue), Empty, jsonValue), arrCharsToEscape, arrEscapedChars)
        'Sonderzeichen ausserhalb Ascii 32 bis 127 ersetzen
        Dim i As Integer: For i = Len(jsonValue) To 1 Step -1
            Dim uChrCode As String: uChrCode = Asc(Mid(jsonValue, i, 1))
            If uChrCode < 32 Or 127 < uChrCode Then jsonValue = replaceIndex(jsonValue, char2unicode(Mid(jsonValue, i, 1)), i - 1, 2)
        Next i
        '\u005C zu \\ wandeln
        jsonValue = Replace(jsonValue, C_UNICODE_BACKSLASH, "\\")
        jsonValue = qm & jsonValue & qm
    'Number
    Else                                    'Zahlen normal ausgeben
        jsonValue = iVar
    End If
End Function

'-------------------------------------------------------------------------------
' JSON to Object
'-------------------------------------------------------------------------------
'/**
' * Parst ein JSON-String in Dictionaries und Collections oder Arrays
' * @param  String          JSON-String
' * @param  jsonDecodeParams     Einstellung, ob [...] als Array oder als Collection zurückgegeben wird
' * @param  Variant         Dasselbe wie der Return-Wert. Wenn amn json2obj() als sub() aufruft, muss man sich nicht darum kümmern, ob ein Array oder ein Object zurückkommt.
' * @return Variant         Dictionary, Collection oder Array
' */
Public Function json2obj(ByVal iString As Variant, Optional ByVal iDecodeParams As jsonDecodeParams = jrtDefault, Optional ByRef oObj As Variant) As Variant

    Dim pts()   As Variant:  ReDim pts(0): Set pts(0) = Nothing
    Dim str     As String:      str = strReplace(iString, Array(vbCrLf, vbCr, vbLf, vbTab), Array(Empty))
On Error GoTo Err_Handler

    If Trim(Nz(iString)) = Empty And (iDecodeParams And jrtEmptyList) Then
        If (iDecodeParams And jrtCollection) Then
            Set oObj = New collection: Set json2obj = oObj
         ElseIf (iDecodeParams And jrtDictionary) Then
            Set oObj = CreateObject("scripting.Dictionary"): Set json2obj = oObj
        Else
            oObj = Array(): json2obj = oObj
        End If
        Exit Function
    ElseIf Trim(Nz(iString)) = Empty Then
        Set oObj = Nothing: Set json2obj = oObj
        Exit Function
    End If

    str = Replace(str, "\'", C_UNICODE_SINGLE_QUOTES)
    str = Replace(str, "\""", C_UNICODE_DOUBLE_QUOTES)
    
    Dim mc As Object: Set mc = rxQuotes.execute(str)
    Dim lastQuote As String:    lastQuote = Empty
    Dim start As Long:          start = -1
    Dim idx As Integer: idx = -1
    Erase strings
    Dim i As Integer: For i = mc.count - 1 To 0 Step -1
        If start = -1 Then
            start = mc(i).firstIndex
            lastQuote = mc(i)
        ElseIf lastQuote = mc(i) Then
            'Schliessen
            idx = idx + 1
            ReDim Preserve strings(idx)
            strings(idx) = Mid(str, mc(i).firstIndex + 2, start - mc(i).firstIndex - 1)
            str = replaceIndex(str, "(#" & idx & ")", mc(i).firstIndex, Len(strings(idx)) + 3)
            strings(idx) = Replace(strings(idx), C_UNICODE_SINGLE_QUOTES, "\'")
            strings(idx) = Replace(strings(idx), C_UNICODE_DOUBLE_QUOTES, "\""")
            start = -1
        Else
            'Anders Quote -> ignorieren
        End If
    Next
    'Alle \\ durch den Unicode-Value \u005C ersetzen
    str = Replace(str, "\\", C_UNICODE_BACKSLASH)
    'str = replaceA(str, cache.arrPreCharsToEsc, cache.arrPreEscChars)
    Set mc = rxPreCharsToU.execute(str)
    For i = mc.count - 1 To 0 Step -1
        str = replaceIndex(str, char2unicode(mc(i).SubMatches(0)), mc(i).firstIndex, Len(mc(i)) + 1)
    Next i

    Do While rxParseList.Test(str)
        Set mc = rxParseList.execute(str)
        Dim v As Object: For Each v In mc
            'nächster act bestimmen
            Dim act As Long: act = UBound(pts) + 1:  ReDim Preserve pts(act): Set pts(act) = CreateObject("scripting.Dictionary")
            'Array/Collection auswerten
            If v.SubMatches(1) = "[" Then  'Array
                Dim items As Variant: items = Split(v.SubMatches(2), ",")
                ReDim tmp(UBound(items))
                For i = 0 To UBound(tmp)
                    'Prüfen ob da ein Platzalter für ein SubObject steht
                    If rxParseSub.Test(items(i)) Then
                        'SubObject übernehmen
                        idx = chooseRx(rxParseSub, items(i))
                        If IsObject(pts(idx)) Then Set tmp(i) = pts(idx) Else tmp(i) = pts(idx)
                    Else
                        'Key und Wert übernehmen
                        tmp(i) = parseValue(items(i))
                    End If
                Next i
                'ggf Array in eine Collection umschreiben
                Select Case v.SubMatches(0)
                    Case "#A": pts(act) = tmp
                    Case "#C": Set pts(act) = array2col(tmp)
                    Case "#D": Set pts(act) = array2Dict(tmp)
                    Case Else
                    If (iDecodeParams And jrtCollection) Then
                        Set pts(act) = array2col(tmp)
                    ElseIf (iDecodeParams And jrtDictionary) Then
                        Set pts(act) = array2Dict(tmp)
                    Else
                        pts(act) = tmp
                    End If
                End Select
            'Dictionary auswerten
            Else                'Object
                Set pts(act) = CreateObject("scripting.Dictionary")
                Dim item As Variant: For Each item In Split(v.SubMatches(2), ",")
                    Dim parts As Variant: parts = Split(item, ":")
                    'Prüfen ob da ein Platzalter für ein SubObject steht
                    If rxParseSub.Test(parts(1)) Then
                        'SubObject übernehmen
                        idx = chooseRx(rxParseSub, parts(1))
                        pts(act).add parseValue(parts(0)), pts(idx)
                    Else
                        'Key und Wert übernehmen
                        pts(act).add parseValue(parts(0)), parseValue(parts(1))
                    End If
                Next item
            End If
            'Das SubObject im JSON-String durch ein Pattern ersetzen &##3; für das 3te SubObject
            str = Replace(str, v.value, format(act, C_PARSE_PLACEHOLDER_F))
        Next v
    Loop

    'Der letzte Eintrag beinhaltet das endgültige Resultat
    If isNothing(pts(act)) And (iDecodeParams And jrtEmptyList) Then
        If (iDecodeParams And jrtCollection) Then
            Set oObj = New collection
            oObj.add iString:   Set json2obj = oObj
         ElseIf (iDecodeParams And jrtDictionary) Then
            Set oObj = CreateObject("scripting.Dictionary"):
            oObj.add 0, iString:  Set json2obj = oObj
        Else
            ReDim oObj(0): oObj(0) = iString
            json2obj = oObj
        End If
    ElseIf IsObject(pts(act)) Then
        Set json2obj = pts(act):   Set oObj = json2obj
    Else
        json2obj = pts(act):       oObj = json2obj
    End If
Exit_Handler:
On Error Resume Next
    Set mc = Nothing
    Set v = Nothing

    Exit Function
Err_Handler:
    Error (Err.Number)
    GoTo Exit_Handler
    Resume
End Function


'/**
' * Parst ein Value in das richtige Format
' * @param  String      JSON-Value-String
' * @param  Variant     Null, Boolean, Number oder String
' */
Private Function parseValue(ByVal iString As String) As Variant
    Dim mc As Object: Set mc = rxStringIndex.execute(iString)
    Dim i As Integer: For i = 0 To mc.count - 1
        iString = Replace(iString, mc(i), strings(mc(i).SubMatches(0)))
    Next i
    
    Select Case UCase(iString)
    'Null
        Case "NULL":            parseValue = Null
    'Boolean
        Case "TRUE", "FALSE":   parseValue = CBool(iString)
        Case Else:
    'Datum
            If rxDate.Test(iString) Then
                Dim m As Object: Set m = rxDate.execute(iString)(0)
                If m.SubMatches(1) + m.SubMatches(2) + m.SubMatches(3) > 0 Then parseValue = DateSerial(m.SubMatches(1), m.SubMatches(2), m.SubMatches(3))
                If m.SubMatches(4) + m.SubMatches(5) + m.SubMatches(6) > 0 Then parseValue = parseValue + TimeSerial(m.SubMatches(4), m.SubMatches(5), m.SubMatches(6))
                'parseValue = DateSerial(m.SubMatches(1), m.SubMatches(2), m.SubMatches(3)) + TimeSerial(m.SubMatches(4), m.SubMatches(5), m.SubMatches(6))
    'String
            ElseIf rxRemoveQuted.Test(iString) Then
                parseValue = iString
                'Umschliessing entfernen
                parseValue = rxRemoveQuted.Replace(parseValue, "$2")
                'Spezialcharakters zurücksetzen
                parseValue = strReplace(IIf(IsNull(parseValue), Empty, parseValue), arrEscapedChars, arrCharsToEscape)
                'Spezialcharakters escapen: \u00166 zu ¦
                parseValue = deEscape(parseValue, rxSpezChars)
    'Zahlen
            ElseIf IsNumeric(iString) Then
                parseValue = CDec(iString)
                If isDouble(iString) Then parseValue = CDbl(iString)
                If isInteger(iString) Then parseValue = CInt(iString)
                If isLong(iString) Then parseValue = CLng(iString)
    'Undefinierter Rest
            Else
                parseValue = iString
            End If
    End Select
End Function

'/**
' * Exsacape-Sequenzen auflösen
' * @param  Value-String
' * @param  RegExp
' * @return String
' */
Private Function deEscape(ByVal iParseValue As Variant, ByRef iRx As Object) As String
    
    deEscape = iParseValue
    'Spezialcharakters escapen: \u00166 zu ¦
    'Spezialcharakters escapen: \t zu Tablulator
    Dim mc As Object: Set mc = iRx.execute(iParseValue)
    Dim i As Integer: For i = mc.count - 1 To 0 Step -1
        deEscape = replaceIndex(deEscape, unicode2Char(mc(i)), mc(i).firstIndex, Len(mc(i)) + 1)
    Next i

End Function

'-------------------------------------------------------------------------------
' Private Cached Properties
'-------------------------------------------------------------------------------
'Die Cache-Verwaltung als Dictionary
Private Property Get cache() As Object
    If pCache Is Nothing Then Set pCache = CreateObject("scripting.Dictionary")
    Set cache = pCache
End Property
Private Property Set cache(ByRef iCache As Object)
    Set pCache = iCache
End Property

Private Property Get arrCharsToEscape()
    If Not cache.exists("arrCharsToEscape") Then cache.add "arrCharsToEscape", Array(vbTab, vbLf, vbCr, vbFormFeed, ":", ",", """", "'")
    arrCharsToEscape = cache("arrCharsToEscape")
End Property
Private Property Get arrEscapedChars()
    If Not cache.exists("arrEscapedChars") Then cache.add "arrEscapedChars", Array("\t", "\n", "\r", "\f", "\:", "\,", "\""", "\'")
    arrEscapedChars = cache("arrEscapedChars")
End Property

Private Property Get rxPreCharsToU() As Object
    If Not cache.exists("rxPreCharsToU") Then cache.add "rxPreCharsToU", cRegExp("\\([\[\]\{\}:,])", rxpGlobal)
    Set rxPreCharsToU = cache("rxPreCharsToU")
End Property

'Unicode zu CHaracter  \u0016 -> ¦
Private Property Get rxSpezChars() As Object
    If Not cache.exists("rxSpezChars") Then cache.add "rxSpezChars", cRegExp("\\u([\dA-F]{4})", rxpGlobal)
    Set rxSpezChars = cache("rxSpezChars")
End Property

'RegEx um die umschliessenden Hochkommas eines Textes zu entfernen
Private Property Get rxRemoveQuted() As Object
    If Not cache.exists("rxRemoveQuted") Then cache.add "rxRemoveQuted", cRegExp("^([""'])(.*)\1$")
    Set rxRemoveQuted = cache("rxRemoveQuted")
End Property

'RegEx um ein Subobjekt zu finden
Private Property Get rxParseSub() As Object
    If Not cache.exists("rxParseSub") Then cache.add "rxParseSub", cRegExp("^&##(\d{3});$", rxpGlobal)
    Set rxParseSub = cache("rxParseSub")
End Property

'RegEx um die Listen {..} und [...] zu finden
Private Property Get rxParseList() As Object
    If Not cache.exists("rxParseList") Then cache.add "rxParseList", cRegExp("(#A|#C|#D|)([\[\{])([^\[\{\]\}]*)[\]\}]", rxpGlobal)
    Set rxParseList = cache("rxParseList")
End Property

Private Property Get rxStringIndex() As Object
    If Not cache.exists("rxStringIndex") Then cache.add "rxStringIndex", cRegExp("\(#(\d+)\)", rxpGlobal)
    Set rxStringIndex = cache("rxStringIndex")
End Property

'Datum erkennen und zerlegen
Private Property Get rxDate() As Object
    If Not cache.exists("rxDate") Then cache.add "rxDate", cRegExp("^(['""]?)(?:(\d{4})[-/\.](\d{2})[-/\.](\d{2}))?(?:[T ]?(\d{2}):(\d{2}):(\d{2}))?\1$", rxpGlobal + rxpIgnorCase) '2012-04-23T18:25:43.511
    Set rxDate = cache("rxDate")
End Property
'RegEx um die Strings (mit ' umschlossene Teile ) zu extrahieren: Single Quoted
Private Property Get rxQuotes() As Object
    If Not cache.exists("rxQuotes") Then cache.add "rxQuotes", cRegExp("(['""#])", rxpGlobal)
    Set rxQuotes = cache("rxQuotes")
End Property

'-------------------------------------------------------------------------------
' Internal Functions
'-------------------------------------------------------------------------------
'/**
' * Erstellt ein RegExp-Object mit den Grundeinstellungen

' * @param  String          Pattern analog RegExp oder mit Delimiter und Modifier analog zu PHP
' * @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")
    If rxPattern.Test(iPattern) Then
        Dim sm As Object: Set sm = rxPattern.execute(iPattern)(0).SubMatches
        cRegExp.pattern = sm(1)
        cRegExp.IgnoreCase = sm(2) Like "*i*"
        cRegExp.Global = sm(2) Like "*g*"
        cRegExp.Multiline = sm(2) Like "*m*"
    Else
        cRegExp.pattern = iPattern
        cRegExp.Global = iFlag And rxpGlobal
        cRegExp.IgnoreCase = iFlag And rxpIgnorCase
        cRegExp.Multiline = iFlag And rxpMultiline
    End If
End Function

'/**
' * Den RegExp um das Pattern aufzulösen
' * @return RegExp-Object
' */
Private Property Get rxPattern() As Object
    If Not cache.exists("rxPattern") Then
        cache.add "rxPattern", CreateObject("VBScript.RegExp")
        cache("rxPattern").pattern = "^([@&!/~#=\|])(.*)\1([igm]{0,3})$"
    End If
    Set rxPattern = cache("rxPattern")
End Property


'/**
' * 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 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
' *
' * Hilfsfunktion. Gibt ein Submatch aus einem RegEx.execute() zurück
' * @param  RegExp          RegExp-Objekt
' * @param  String          Der String der bearbeitet werden soll
' * @param  Integer         Match von dem das Subitem ausgegeben werden soll. Beginnt mit 1
' * @param  Integer         SubMatch der ausgegeben werden soll. Bei 0 wird der gesammte Match ausgegeben Beginnt mit 0
' * @return Wert oder False
' */
Private Function chooseRx( _
        ByRef iRx As Object, _
        ByVal iSubject As String, _
        Optional ByVal iMatchIndex As Integer = 1, _
        Optional ByVal iSubMatchIndex As Integer = 1 _
) As Variant
    Dim mc      As Object:  Set mc = iRx.execute(iSubject)
    Dim idxSm   As Integer: idxSm = iSubMatchIndex - 1
    Dim idxM    As Integer: idxM = iMatchIndex - 1

    If Not mc Is Nothing Then
        If mc.count > idxM And idxM >= 0 Then
            If idxSm = -1 Then
                chooseRx = mc.item(idxM)
                GoTo Exit_Handler
            ElseIf mc.item(idxM).SubMatches.count > idxSm And idxSm >= 0 Then
                chooseRx = mc.item(idxM).SubMatches(idxSm)
                GoTo Exit_Handler
            End If
        End If
    End If
    chooseRx = False

Exit_Handler:
    Set mc = Nothing
End Function

'/**
' * Copyright mpl by ERB software | http://wiki.yaslaw.info
' *
' * Ersetzt ein pestimmte Position in einem String
' * @param  String      Heystack
' * @param  String      Ersetzungsstring
' * @param  Integer     Position im String
' * @param  Integer     Länge des zu ersetzenden Strings
' */
Private Function replaceIndex(ByVal iExpression As Variant, ByVal iReplace As Variant, ByVal iIndex As Variant, Optional ByVal iLength As Integer = 1) As String
    replaceIndex = Left(iExpression, iIndex) & iReplace & Mid(iExpression, iIndex + iLength)
End Function

'/**
' * Ersetz in einem String mehrere Substrings. Normal oder mit RegExp
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/strreplace
' * V1.1.0
' * @param  String      Der Text, ind em ersetzt werden soll
' * @param  ParamArray  Die Ersetzungsargumente
' * @return String
' */
Private Function strReplace( _
        ByVal iExpression As Variant, _
        ParamArray iItems() As Variant _
) As Variant
    If IsNull(iExpression) Then Exit Function
    Dim items() As Variant: items = CVar(iItems)
    'Parameters zusammenstellen: Dictionary([Pattern] => [Replace])
    Dim dict As Dictionary: Set dict = cDict(items)
    'Keys extrahieren, da bei Latebinding nicht über den ndex auf das Dictionary zugegriffen werden kann
    Dim keys() As Variant: keys = dict.keys
    'Aufbrösmeln: repl = array(flRx => [RegExp des einzelnen Suchwertes], flReplace => [Ersatzstring])
    Dim repl() As Variant: ReDim repl(dict.count - 1)
    Dim idxI As Integer: For idxI = 0 To dict.count - 1
        Dim searchPattern As String: searchPattern = keys(idxI)                 'Suchpattern auslesen
        If rxPattern.Test(searchPattern) Then                                   'Falls gültiger Pattern
            searchPattern = rxPattern.execute(searchPattern)(0).SubMatches(1)   'Den eigentlichen Pattern extrahieren
            repl(idxI) = Array(cRegExp(keys(idxI)), dict(keys(idxI)))            'und den Array zusammenstellen
        Else
            searchPattern = escapeString(searchPattern)                         'Pattern Escapen, damit es kein RegExp-Search gibt
            repl(idxI) = Array(cRegExp(searchPattern, rxpIgnorCase), dict(keys(idxI)))
        End If
        Dim pp() As String: ReDim Preserve pp(idxI): pp(idxI) = "(" & searchPattern & ")"   'Alle SearchPattern in einme Array sammeln
    Next idxI
    Dim pattern As String: pattern = "(?:" & Join(pp, "|") & ")"                'und zu einem grossen Pattern zusammensetzen: (?(pattern1)|(pattern2)...|(patternN))
    Dim rx As Object: Set rx = cRegExp(pattern, rxpGlobal + rxpIgnorCase)        'und damit ein GesammtsuchRegExp erstellen
    
    strReplace = iExpression
    
    Dim mc As Object: Set mc = rx.execute(iExpression)                          'Gesammtsuche ausführen
    Dim idxM As Integer: For idxM = mc.count - 1 To 0 Step -1
        Dim arr As Variant: For Each arr In repl                                'Für jeden Treffer den richtigen TeilRegExp suchen und den Teilstring ersetzen
            If arr(flRx).Test(mc(idxM).value) Then
                strReplace = substrReplace( _
                        iString:=strReplace, _
                        iReplacement:=arr(flRx).Replace(mc(idxM).value, arr(flReplace)), _
                        iStart:=mc(idxM).firstIndex, _
                        iLength:=mc(idxM).length _
                )
                Exit For
            End If
        Next arr
    Next idxM
    
End Function

'-------------------------------------------------------------------------------
' -- Private Methodes
'-------------------------------------------------------------------------------

'/**
' * Escapte alle Sonderzeichen um eine rx-Pattern zu erstellen
' *
' *     string = rx_escape_string(string)
' *
' * @example    rx_escape_string("Hallo Welt. Geht es dir (noch) gut?")
' *             Hallo Welt\. Geht es dir \(noch\) gut\?
' * @param  String
' * @return String
' */
Private Function escapeString( _
        ByVal iString As String _
) As String
    escapeString = rxEscapeStrings.Replace(iString, "\$1")
End Function

'-------------------------------------------------------------------------------
' -- Private Properties
'-------------------------------------------------------------------------------
Private Property Get rxEscapeStrings() As Object
    If Not cache.exists("rxEscapeStrings") Then cache.add "rxEscapeStrings", cRegExp("([\\\*\+\?\|\{\[\(\)\^\$\.\#])", rxpGlobal)
    Set rxEscapeStrings = cache("rxEscapeStrings")
End Property
'
'Private Property Get rxRemoveMarks() As Object
'    If rxCachedRemoveMarks Is Nothing Then Set rxCachedRemoveMarks = cRegExp(C_RX_REMOVEMARKS_PATTERN, rxpGlobal)
'    Set rxRemoveMarks = rxCachedRemoveMarks
'End Property


'/**
' * Copyright mpl by ERB software | http://wiki.yaslaw.info
'*
' * Hilfsfunktion: Ein Array in eine Collection wandeln
' * @param  Array
' * @return Collection
' */
Private Function array2col(ByVal iArray As Variant) As collection
    Set array2col = New collection
    Dim item As Variant: For Each item In iArray
        array2col.add item
    Next item
End Function

'/**
' * Copyright mpl by ERB software | http://wiki.yaslaw.info
'*
' * Hilfsfunktion: Ein Array in eine Collection wandeln
' * @param  Array
' * @return Collection
' */
Private Function array2Dict(ByVal iArray As Variant) As Object
    Set array2Dict = CreateObject("scripting.Dictionary")
    Dim i As Integer: For i = 0 To UBound(iArray)
        array2Dict.add i, iArray(i)
    Next i
End Function

'/**
' * Copyright mpl by ERB software | http://wiki.yaslaw.info
' *
' * Prüft on ein Value ein Double-Wert ist
' * @param  Variant     Zu prüfender Wert
' * @param  Boolean     Flag ob ein Integer/Long als Double akzeptiert werden soll
' * @return Boolean
' */
Private Function isDouble(ByVal iExpression As Variant, Optional ByVal iWithIntLng As Boolean = False) As Boolean
    If Not IsNumeric(iExpression) Then Exit Function
    isDouble = (CDbl(iExpression) = iExpression)
    If Not iWithIntLng And isDouble Then isDouble = Not isLong(iExpression, True)
End Function

'/**
' * Copyright mpl by ERB software | http://wiki.yaslaw.info
' *
' * Prüft on ein Value ein Integer-Wert ist
' * @param  Variant     Zu prüfender Wert
' * @return Boolean
' */
Private Function isInteger(ByVal iExpression As Variant) As Boolean
    If Not IsNumeric(iExpression) Then Exit Function
    If iExpression < -32768 Or 32767 < iExpression Then Exit Function
    isInteger = (CInt(iExpression) = iExpression)
End Function

'/**
' * Copyright mpl by ERB software | http://wiki.yaslaw.info
' *
' * Prüft on ein Value ein Long-Wert ist
' * @param  Variant     Zu prüfender Wert
' * @param  Boolean     Angabe, ob Integer auch als Long gelten (Integer: -32768 bos 32767)
' * @return Boolean
' */
Private Function isLong(ByVal iExpression As Variant, Optional ByVal iWithInteger As Boolean = False) As Boolean
    If Not IsNumeric(iExpression) Then Exit Function
    If iExpression < -2147483648# Or 2147483647 < iExpression Then Exit Function
    isLong = (CLng(iExpression) = iExpression)
    If Not iWithInteger And isLong Then isLong = Not isInteger(iExpression)
End Function

'/**
' * Wandelt verschiedene Formate in ein Dictionary um
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cdic
' * @param  ParamArray
' * @return Dictionary
' */
Private Function cDict(ByRef iItems() As Variant) As Dictionary
    Set cDict = New 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 = eval("#" & value & "#")
                        Case Empty: value = CDec(value)
                        Case Else:  value = cRegExp("\\(['""])", rxpGlobal).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 RegExp-Cache um ein Set-String zu zerlegen
' * @return RegExp
' */
Private Property Get rxSetString() 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