Funktionen rund um JSON-Strings: obj2json() und json2obj().

Download lib_json.bas (V-2.0.5)

Für mehrere Projekte brauche ich JSON. Ich arbeitete bisher mit VB-JSON. Aber irgendwie störte es mich, dafür jeweils 2 Klassen und ein Modul zu kopieren. Bei der Analyse des Codes war ich erstaunt, dass er ohne Reguläre Ausdrücke arbeitet.

Darum setzte ich mich mal hin, eine eigene Version zu erstellen. Messungen haben ergeben, dass beide etwa gleich schnell sind.

Ich versuchte mich möglichst nahe an JavaScript Object Notation hinzukommen. Nur wenn man beim JSON erstrellen den Parameter jqmInternalArrayPrefix mitgibt, kommen TypenPrefixe vor die [] um zu definieren ob es sich um ein Array oder eine Collection handelt

Public Function obj2json( _
    ByRef iObj As Variant, _
    Optional ByVal iEncodeParams As jsonEncodeParams = jqmDefault _
) As String

• iObj Das Objekt (Dictionary, Collection, Array), welches in ein JSON-String geschrieben werden soll
• iEncodeParams Angabe, was für einAnführungszeichen verwendet werden soll

Gibt ein JSON-String zurück

Public Function json2obj( _
    ByVal iString As Variant, _
    Optional ByVal iParams As jsonDecodeParams = jrtDefault, _
    Optional ByRef oObj As Variant) As Variant

• iString JSON-String, der geparst werden soll
• iParams Steuert, ob […] als Array oder als Collection zurückgegeben wird
• oObj das geparste Objekt, analog zurm Returnvalue. Auf diese Art muss man den Return-Wert nicht zuerst prüfen ob es ein Array oder ein Object ist

Ein Dictionary-, Collection-Object oder ein Variant-Array

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 (Dictionaries)
    jqmInternalArrayPrefix = 2 ^ 4      'Der JSON-String wird mit eigenen Prefixen bei Array und Collection mitgeliefert
    jqmReverseSolidusAsUnicode = 2 ^ 5  'Ein \ in einem String wird nicht als \\ sondern als Unicode gaparst
    jqmDefault = jqmDoubleQuote
End Enum

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
    jrtNotCastValue = 2 ^ 4 'cast der Values verhindern
    jrtEmptyList = 2 ^ 5    'Angabe, ob bei einem Leeren String eine Collection/Array/Dictionary zurückgegeben werden soll
    jrtSingle2List = 2 ^ 6  'Parst ein einzelnesItem zu einer Liste
    jrtDefault = jrtArray
End Enum

Hier einige Anwendungsbeispiele

Für die Ausgabe der Resultate verwendete ich die Funktion [VBA] print_r().

'1) Einfacher Array
print_r obj2json(array(1,2,3))
<String> '[1,2,3]'

'2a) Array mit Texten und doppelten Anführungszeichen
print_r obj2json(array("a","b","c"))
<String> '["a","b","c"]'
'2b) Dito mit einfachen Anführungszeichen
print_r obj2json(array("a","b","c"), jqmSingleQuote)
<String> '['a','b','c']'

Public Sub testObj2Json()
    Dim c As New Collection
    Dim d As New Dictionary
 
    c.add True              'Boolen-Wert
    c.add Array(1, 2, 3)    'Normaler Zehlenarray
 
    d.add "t1", "a" & vbTab & "b"     'Text mit Tabulator
    d.add "t2", "a¦'b':{1....n}"  'Text mit Sonderzeichen, ' und {}
 
    c.add d
    c.add Null              'Null
    c.add Now               'Datum/Urhzeit
 
    Debug.Print "'Object"
    print_r c               'Ganze Collection c anzeigen
    Debug.Print "'JSON-String"
    print_r obj2json(c, jqmSingleQuote)
 
    Set d = Nothing
    Set c = Nothing
End Sub

Und die Ausgabe davon

'Object
<Collection>  (
    [1] => <Boolean> True
    [2] => <Variant()>  (
        [0] => <Integer> 1
        [1] => <Integer> 2
        [2] => <Integer> 3
    )
    [3] => <Dictionary>  (
        [t1] => <String> 'a\tb'
        [t2] => <String> 'a¦'b':{1....n}'
    )
    [4] => <Null> 
    [5] => <Date> 26.11.2014 12:37:03
)
'JSON-String
<String> '[true,[1,2,3],{'t1':'a\u0009b','t2':'a\u00A6\u0027b\u0027:{1....n}'},null,2014-11-26T12:37:03]'

Und alles wieder zurück

'Als Array
print_r json2obj("[1,2,3]")
<Variant()>  (
    [0] => <Byte> 1
    [1] => <Byte> 2
    [2] => <Byte> 3
)
'Als Collection
print_r json2obj("[1,2,3]", jrtCollection)
<Collection>  (
    [1] => <Byte> 1
    [2] => <Byte> 2
    [3] => <Byte> 3
)

'2a) Array mit Texten und doppelten Anführungszeichen
print_r json2obj("[""a"",""b"",""c""]")
<Variant()>  (
    [0] => <String> 'a'
    [1] => <String> 'b'
    [2] => <String> 'c'
)
 
'2b) Dito mit einfachen Anführungszeichen
print_r json2obj("['a','b','c']")
<Variant()>  (
    [0] => <String> 'a'
    [1] => <String> 'b'
    [2] => <String> 'c'
)

print_r json2obj("[true,[1,2,3],{'t1':'a\tb','t2':'a\u00A6\'b\'\:{1....n}'},null,'2014-02-24T11:11:41']")
<Variant()>  (
    [0] => <Boolean> True
    [1] => <Variant()>  (
        [0] => <Byte> 1
        [1] => <Byte> 2
        [2] => <Byte> 3
    )
    [2] => <Dictionary>  (
        [t1] => <String> 'a\tb'
        [t2] => <String> 'a¦'b'\:{1....n}'
    )
    [3] => <String> 'null'
    [4] => <Date> 24.02.2014 11:11:41
)

Ich verwende in diesem Beispiel die Funkionen [VBA] cDict() und [VBA] cCollection() im ein Dictionary bzw. eine Collection zu erstellen.

'Normaler cast
print_r obj2json(cCollection(1,"c",cDict("b",array(1,2))))
<String> '[1,"c",{"b":[1,2]}]'
 
'Mit jqmInternalArrayPrefix
print_r obj2json(cCollection(1,"c",cDict("b",array(1,2))), jqmInternalArrayPrefix)
<String> '#C[1,'c',{'b':#A[1,2]}]'
 
'Und die Rückwandlung ohne den Prefix. Beachte, aus dem ursprünglichen Collection wurde ein Array
print_r json2obj("[1,'c',{'b':[1,2]}]")
<Variant()>  (
    [0] => <Byte> 1
    [1] => <String> 'c'
    [2] => <Dictionary>  (
        [b] => <Variant()>  (
            [0] => <Byte> 1
            [1] => <Byte> 2
        )
    )
)
'Und mit PRefixen wird der Richtige Listentyp wieder hergestellt
print_r json2obj("#C[1,'c',{'b':#A[1,2]}]")
<Collection>  (
    [1] => <Byte> 1
    [2] => <String> 'c'
    [3] => <Dictionary>  (
        [b] => <Variant()>  (
            [0] => <Byte> 1
            [1] => <Byte> 2
        )
    )
)

lib_json.bas

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      : 2.9.1
'Name         : json
'Author       : Stefan Erb (ERS)
'History      : 19.02.2014 - ERS - Creation
'               ...
'               16.09.2019 - ERS - bei json2obj eine Stringeingabe mit Paramter hinzugefügt
'               17.09.2019 - ERS - Fehler in cVal korrigiert
'               09.10.2019 - ERS - Div. kleine Fehler behoben
'               14.10.2019 - ERS - Json to Collection um die Keys ergänzt
'               17.10.2019 - ERS - Bei json2Dict Führende Leerzeichen beim Key entfernt
'               24.10.2019 - ERS - ' Maskieren hinzugefügt. Wichtg:! jqmDefault von jqmDoubleQuote auf jqmSingleQuote + jqmMask gewechselt
'               16.01.2020 - ERS - cV() korrigiert, damit zB der String Name nicht ausgeführt wird
'
'http://de.wikipedia.org/wiki/JavaScript_Object_Notation
'-------------------------------------------------------------------------------
Option Explicit
 
'-------------------------------------------------------------------------------
' -- ! SETTINGS !
'-------------------------------------------------------------------------------
'In Excel und Word funktionieren Eval() nicht. Auch der NZ() gibt es dort nicht.
'Darum hier angeben ob es sich um MS Access handelt oder eben nicht. Leider gibts datzu keine Systemvariable
#Const IS_ACCESS = True
 
'-------------------------------------------------------------------------------
' Public Members
'-------------------------------------------------------------------------------
'/**
' * Einstellungen, ob [...] in ein Array oder in eine Collection geschrieben werden soll
' */
Public Enum jsonDecodeParams
    jrtCollection = 2 ^ 1               '[c] Als Collection
    jrtArray = 2 ^ 2                    '[a] Als Array
    jrtDictionary = 2 ^ 3               '[d] Als Dictionary
    jrtNotCastValue = 2 ^ 4             '[n] cast der Values verhindern
    jrtEmptyList = 2 ^ 5                '[L] Angabe, ob bei einem Leeren String eine Collection/Array/Dictionary zurückgegeben werden soll
    jrtEmptyDictionary = 2 ^ 7          '[D] bei jrtEmptyList wird anhand von jrtDictionary etc. bestimmt was es sein soll. jrtDictionary jedoch parst nachher alles in ein Dictionary. DIeses Setting nur Empty
    jrtSingle2List = 2 ^ 6              '[S] Parst ein einzelnesItem zu einer Liste (Input ist kein Json-String)
    jrtDefault = jrtArray
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 (Dictionaries)
    jqmInternalArrayPrefix = 2 ^ 4      'Der JSON-String wird mit eigenen Prefixen bei Array und Collection mitgeliefert
    jqmReverseSolidusAsUnicode = 2 ^ 5  'Ein \ in einem String wird nicht als \\ sondern als Unicode gaparst
    jqmNoErrorForWrongType = 2 ^ 6      'Wenn ein nicht parsbarer Wert kommt, den TypeName() ausgeben
    jqmSingle2Array = 2 ^ 7             'Einzelwerte als Array ausgeben
    jqmNoUnicode = 2 ^ 8                'Keine Sonderzeichen in Unicode wandeln
    jqmUnicodeInsteadOfMask = 2 ^ 9     'Anstelle von Maskierungen werden '[{ etc. mit unicode dargestellt
    jqmDefault = jqmSingleQuote
End Enum
 
Public Const JSON_ERROR_INVALID_INPUT = vbObjectError + 1
 
'-------------------------------------------------------------------------------
' Private Members
'-------------------------------------------------------------------------------
'ISO 8601 :standard: "2012-03-19T07:22Z".
'Datums-Format nach ISO 8601
Public Const C_OBJ2JSON_DATE_FORMAT_DEFAULT = "YYYY-MM-DD\T"
Public Const C_OBJ2JSON_TIME_FORMAT_DEFAULT = "HH:NN:SS\Z"
Public Const C_OBJ2JSON_TIMESTAMP_FORMAT_DEFAULT = "YYYY-MM-DD\THH:NN:SS\Z"
Public Const C_JSON2OBJ_TIMESTAMP_PATTERN = "/^(?:['""]?(\d{4}-\d{2}-\d{2})T)?(?:(\d{2}:\d{2}:\d{2})Z['""]?)?$/i"
Public Const C_JSON2OBJ_TIMESTAMP_REPLACE = "['""]?$1 $2['""]?"
 
'Unicode eines \
Private Const C_UNICODE_BACKSLASH = "\u005C"
Private Const C_UNICODE_ = "\u003A"
 
Private Enum cvHandling
    cvhNullTextAsNull = 2 ^ 0   'Der Text Null ohne Delemiter wird als Wert Null intepretiert
    cvhEmptyAsNull = 2 ^ 1      'Ein leerer String wird als Null intepretiert
    cvhNotCast = 2 ^ 2
End Enum
 
Private Declare Function emptyArrayVariant Lib "oleaut32" Alias "SafeArrayCreateVector" (Optional ByVal vt As VbVarType = vbVariant, Optional ByVal lLow As Long = 0, Optional ByVal lCount As Long = 0) As Variant()
 
'-------------------------------------------------------------------------------
'-- Private members for cDict()
'-------------------------------------------------------------------------------
'Private rxCachedSetString As Object
 
Private o2jParams           As jsonEncodeParams     'Die jsonEncode-Paramters
Private stringDelemiter     As String * 1           'Delemter des aktuellen String
Private j2oParams           As jsonDecodeParams
Private pDateFormat         As String
Private pTimeFormat         As String
Private pTimeStampFormat    As String
Private pTimeStampTemplate   As String
Private pTimeStampReplace   As String
Private pJ2ORxDate          As Object:
 
'-------------------------------------------------------------------------------
' 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
    o2jParams = iEncodeParams
    stringDelemiter = IIf(andB(iEncodeParams, jqmDoubleQuote), """", "'")
 
    If Not (IsArray(iObj) Or TypeName(iObj) = "Collection" Or TypeName(iObj) = "Dictionary") Then
        If andB(iEncodeParams, jqmSingle2Array) Then
            iObj = Array(iObj)
        ElseIf andB(iEncodeParams, jqmNoErrorForWrongType) Then
            iObj = "<" & TypeName(iObj) & ">"
        Else
            Err.Raise JSON_ERROR_INVALID_INPUT, "json", "Input is not a array or Collection or Dictionary"
        End If
    End If
    obj2json = o2jRekursive(iObj)
    obj2json = o2jUnicode2Mask(obj2json, iEncodeParams)
    'If andB(iEncodeParams, jqmSingleQuote) Then obj2json = replace(obj2json, "\u0027", "\'")
End Function
 
'/**
' * Interner Stringersteller
' * @param  Objekt
' * @param  jsonEncodeParams      Angabe über die Art der Anführungszeichen im JSON-String
' * @return String
' */
Private Function o2jRekursive(ByRef iObj As Variant) As String
    'Array
    If IsArray(iObj) Then
        o2jRekursive = o2jArray(iObj)
    'Collection
    ElseIf TypeName(iObj) = "Collection" Then
        o2jRekursive = o2jCollection(iObj)
    'Dictionary
    ElseIf TypeName(iObj) = "Dictionary" Then
        o2jRekursive = o2jDict(iObj)
    ElseIf IsObject(iObj) And andB(o2jParams, jqmNoErrorForWrongType) Then
        o2jRekursive = "<" & TypeName(iObj) & ">"
    '[Key:]Value
    Else
        o2jRekursive = o2jValue(iObj)
    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 o2jCollection(ByRef iCollection As Variant) 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
 
    o2jCollection = o2jArray(arr)
    If (o2jParams And jqmInternalArrayPrefix) Then
        o2jCollection = "#C" & Mid(o2jCollection, 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 o2jArray(ByVal iArray As Variant) As String
    Dim i As Long: For i = LBound(iArray) To UBound(iArray)
        iArray(i) = o2jRekursive(iArray(i))
    Next i
 
    If o2jParams And jqmForceObject Then
        o2jArray = "[" & join(iArray, ",") & "]"
    Else
        o2jArray = "[" & join(iArray, ",") & "]"
    End If
    If o2jParams And jqmInternalArrayPrefix Then o2jArray = "#A" & o2jArray
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 o2jDict(ByRef iDict As Variant) As String
    If iDict.count = 0 Then
        o2jDict = IIf(o2jParams And jqmForceObject, "{}", "")
        Exit Function
    End If
 
    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) = o2jValue(keys(i)) & ":" & o2jRekursive(items(i))
    Next i
    o2jDict = "{" & 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 o2jValue(ByVal iVar As Variant) As String
    'Null
    If IsNull(iVar) Then                    'Null-Werte als null zurückgeben
        o2jValue = "null"
    'Boolean
    ElseIf TypeName(iVar) = "Boolean" Then  'Boolen als true/false ausgeben
        o2jValue = LCase(CBool(iVar))
    'Date
    ElseIf IsDate(iVar) Then                'Datum
 
        If o2jRxTimeOnly.test(CStr(iVar)) Then
            o2jValue = format(iVar, obj2json_time_format)
        ElseIf (hour(iVar) + minute(iVar) + second(iVar)) = 0 Then
            o2jValue = format(iVar, obj2json_date_format)
        Else
            o2jValue = format(iVar, obj2json_timestamp_format)
        End If
 
 
    'Char
    ElseIf Not IsNumeric(iVar) Then         'Texte als "t\\ext" ausgeben
        '\ zu \u005C wandeln
        o2jValue = replace(iVar, "\", C_UNICODE_BACKSLASH)
        'weitere Spez-Charakters gemäss http://tools.ietf.org/html/rfc7159#section-7
        If Not andB(o2jParams, jqmNoUnicode) Then o2jValue = unicodeSpezChars(o2jValue)
        '\u005C zu \\ wandeln
        If Not o2jParams And jqmReverseSolidusAsUnicode Then
            o2jValue = replace(o2jValue, C_UNICODE_BACKSLASH, "\\")
        End If
 
        o2jValue = stringDelemiter & o2jValue & stringDelemiter
    'Number
    Else                                    'Zahlen normal ausgeben
        o2jValue = iVar
    End If
End Function
 
 
'-------------------------------------------------------------------------------
' JSON to Object
'-------------------------------------------------------------------------------
 
'/**
' * Parst ein JSON-String in Dictionaries und Collections oder Arrays
' * @param  String          JSON-String oder JSON-String mit Paramters  [a,b,c], /[a,b,c]/d
' * @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 iParams As jsonDecodeParams = jrtDefault, Optional ByRef oObj As Variant, Optional ByVal iCompareMode As CompareMethod = CompareMethod.DatabaseCompare) As Variant
 
'    c jrtCollection = 2 ^ 1               'Als Collection
'    a jrtArray = 2 ^ 2                    'Als Array
'    d jrtDictionary = 2 ^ 3               'Als Dictionary
'    n jrtNotCastValue = 2 ^ 4             'cast der Values verhindern
'    L jrtEmptyList = 2 ^ 5                'Angabe, ob bei einem Leeren String eine Collection/Array/Dictionary zurückgegeben werden soll
'    D jrtEmptyDictionary = 2 ^ 7          'bei jrtEmptyList wird anhand von jrtDictionary etc. bestimmt was es sein soll. jrtDictionary jedoch parst nachher alles in ein Dictionary. DIeses Setting nur Empty
'    S jrtSingle2List = 2 ^ 6
 
    Static rxParseParam As Object: If rxParseParam Is Nothing Then Set rxParseParam = cRx("^(\/)(.*?)(?:\1([cadnLDS]+))$")
    If rxParseParam.test(iString) Then
        Dim pp As Object: Set pp = rxParseParam.execute(NZ(iString))(0)
 
        iString = pp.subMatches(1)
        Dim pstr As String: pstr = pp.subMatches(2)
        iParams = 0
        If InStrB(pstr, "c") And Not andB(iParams, jrtCollection) Then iParams = iParams + jrtCollection
        If InStrB(pstr, "a") And Not andB(iParams, jrtArray) Then iParams = iParams + jrtArray
        If InStrB(pstr, "d") And Not andB(iParams, jrtDictionary) Then iParams = iParams + jrtDictionary
        If InStrB(pstr, "n") And Not andB(iParams, jrtNotCastValue) Then iParams = iParams + jrtNotCastValue
        If InStrB(pstr, "L") And Not andB(iParams, jrtEmptyList) Then iParams = iParams + jrtEmptyList
        If InStrB(pstr, "D") And Not andB(iParams, jrtEmptyDictionary) Then iParams = iParams + jrtEmptyDictionary
        If InStrB(pstr, "S") And Not andB(iParams, jrtSingle2List) Then iParams = iParams + jrtSingle2List
    End If
    j2oParams = iParams
    If j2oEmptyHandler(iString, json2obj) Then Exit Function
 
 
    Dim strr        As String:      strr = StrReverse(removeSpaces(iString))
    Dim contents    As Object:      Set contents = CreateObject("scripting.Dictionary")
    Dim i           As Integer
 
    'Maskierte Zeichen []{}'"# in Unicode parsen
    Do While j2oRxMaskedChars.test(strr)
        'strr = j2oRxMaskedChars.replace(strr, StrReverse(char2unicode(j2oRxMaskedChars.execute(strr)(0).subMatches(0))))
        strr = j2oRxMaskedChars.replace(strr, StrReverse(j2oDictJsonSpezChars(StrReverse(j2oRxMaskedChars.execute(strr)(0).subMatches(0)))))
    Loop
 
    Dim str As String: str = StrReverse(strr)
 
    'Alle []{}'"# innerhalb eines Strings in Unicode parsen
    If j2oRxStrings.test(str) Then
        Dim mc As Object: Set mc = j2oRxStrings.execute(str)
        For i = mc.count - 1 To 0 Step -1
            Dim substr As String: substr = mc(i).subMatches(1)
            Do While j2oRxCharsInStringToUnicode.test(substr)
                substr = j2oRxCharsInStringToUnicode.replace(substr, CStr(char2unicode(j2oRxCharsInStringToUnicode.execute(substr)(0))))
            Loop
            Dim dm As String: dm = mc(i).subMatches(0)
            str = replaceIndex(str, dm & substr & dm, mc(i).firstIndex, mc(i).Length)
        Next i
    End If
 
    i = 0
    Do While j2oRxParseList.test(str)
        'Key ermitteln
        Dim key As String:  key = format(inc(i), "\&\#\#000\;")   'Ergibt den Key '&##002;'
        Dim sm As Object:   Set sm = j2oRxParseList.execute(str)(0).subMatches
        'Art der liste herausfinden
        Dim listType As jsonDecodeParams
        Select Case UCase(sm(0))
            'Mit IntenralPrefix
            Case "#A":  listType = jrtArray
            Case "#C":  listType = jrtCollection
            Case "#D":  listType = jrtDictionary
            'Anhand des Delemiters und der Settings. bei { ist es ein Dictionary, bei [ je nach Paramters ein Array oder eine Collection
            Case Else:  listType = Switch( _
                            (j2oParams And jrtCollection), jrtCollection, _
                            sm(1) = "{", jrtDictionary, _
                            (j2oParams And jrtDictionary), jrtDictionary + jrtArray, _
                            True, jrtArray _
                        )
        End Select
        'Liste nach Type parsen
        Select Case listType
            Case jrtArray:      contents.add key, j2oArray(contents, sm(2))
            Case jrtCollection: contents.add key, j2oCollection(contents, sm(2))
            Case jrtDictionary: contents.add key, j2oDict(contents, sm(2), iCompareMode)
            Case jrtDictionary + jrtArray: contents.add key, j2oArrayDict(contents, sm(2), iCompareMode)
 
        End Select
        'Liste im JSON durch den Key ersetzen
        str = j2oRxParseList.replace(str, key)
    Loop
    'Der Letzte Inhalt des contents entspricht der json2obj
    If key = "" And isEmpty(contents(key)) And contents.count = 1 And iParams And jrtSingle2List Then
        ref json2obj, json2obj("[" & iString & "]", iParams)
    Else
        ref json2obj, contents(key)
    End If
    ref oObj, json2obj
End Function
 
'/**
' * Handelt eine leere Eingabe
' * @param  IN  String  'Übergabestring aus json2obj()
' * @param  OUT Variant 'Returnwert für json2obj()
' * @return Boolean     'Flag ob iString ein leerer String oder NULL ist
' */
Private Function j2oEmptyHandler(ByVal iString As Variant, ByRef oList As Variant) As Boolean
    j2oEmptyHandler = (trim(NZ(iString)) = Empty)               'Prüfen ob der String als leer gilt
    If Not j2oEmptyHandler Then Exit Function                   'Wenn nicht, funktion verlassen. Rückgabewert = FALSE
    If j2oParams And jrtEmptyDictionary Then
        Set oList = CreateObject("scripting.Dictionary")
        Exit Function
    End If
    If j2oParams And jrtEmptyList Then
        If j2oParams And jrtDictionary Then
            Set oList = CreateObject("scripting.Dictionary")
        ElseIf j2oParams And jrtCollection Then
            Set oList = New Collection
        Else
            oList = emptyArrayVariant()
        End If
    End If
End Function
 
'/**
' * Wandelt ein JSON-String in ein Array
' * @param  Dictionary      Den Container der aktuellen Verschachtelungen
' * @param  String          Listenstring
' * @return Array<Variant>
' */
Private Function j2oArray(ByRef iContents As Object, ByRef iListString As Variant) As Variant
    Dim list As Variant: list = Split(iListString, ",")
    Dim retArr() As Variant: ReDim retArr(UBound(list))
    Dim k As Integer: For k = 0 To UBound(list)
        ref retArr(k), j2oValue(iContents, trim(list(k)))
    Next k
    j2oArray = retArr
End Function
 
'/**
' * Wandelt ein JSON-String in ein Array
' * @param  Dictionary      Den Container der aktuellen Verschachtelungen
' * @param  String          Listenstring
' * @return Array<Variant>
' */
Private Function j2oArrayDict(ByRef iContents As Object, ByRef iListString As Variant, Optional ByVal iCompareMode As CompareMethod = CompareMethod.DatabaseCompare) As Variant
    Dim list As Variant: list = Split(iListString, ",")
    Set j2oArrayDict = CreateObject("scripting.Dictionary")
    j2oArrayDict.CompareMode = iCompareMode
    Dim k As Integer: For k = 0 To UBound(list)
        j2oArrayDict.add k, j2oValue(iContents, trim(list(k)))
    Next k
End Function
 
'/**
' * Wandelt ein JSON-String in eine Collection
' * @param  Dictionary      Den Container der aktuellen Verschachtelungen
' * @param  String          Listenstring
' * @return Collection
' */
Private Function j2oCollection(ByRef iContents As Object, ByRef iListString As Variant) As Object
    Dim list As Object: Set list = j2oDict(iContents, iListString)
    Set j2oCollection = New Collection
    If iListString = "" Then Exit Function
    Dim keys As Variant: keys = list.keys
    Dim k: For Each k In keys
        j2oCollection.add list(k), CStr(k)
    Next k
End Function
 
'/**
' * Wandelt ein JSON-String in ein Dictionary
' * @param  Dictionary      Den Container der aktuellen Verschachtelungen
' * @param  String          Listenstring
' * @return Dictionary
' */
Private Function j2oDict(ByRef iContents As Object, ByRef iListString As Variant, Optional ByVal iCompareMode As CompareMethod = CompareMethod.DatabaseCompare) As Object
    Set j2oDict = CreateObject("scripting.Dictionary")
    j2oDict.CompareMode = iCompareMode
    If iListString = "" Then Exit Function
    Dim list As Object: Set list = cDictAJson(Array(CStr(iListString)))
    Dim keys As Variant: keys = list.keys
    Dim k As Integer: For k = 0 To UBound(keys)
        j2oDict.add j2oValue(iContents, keys(k), True), j2oValue(iContents, list(keys(k)))
    Next k
End Function
 
'/**
' * Gibt ein Value zurück. Parst oder Castet den Wert
' * @param  Dictionary      Den Container
' * @param  Variant         Zu pasender Value
' * @param  Boolean
' * @retrun Variant
' */
Private Function j2oValue(ByVal iContents As Object, ByVal iVar As Variant, Optional ByVal iFirstMatch As Boolean = False) As Variant
    If iContents.exists(iVar) Then                  'Wenn iVar im Container exisitert ist es ein Key. Dann wird der Containerinhalt zurückgegeben
        If iFirstMatch Then
            ref j2oValue, iContents(iVar)(0)
        Else
            ref j2oValue, iContents(iVar)
        End If
    ElseIf j2oParams And jrtNotCastValue Then       'iVar ist ein Wert. Anahnd des Params jrtNotCastValue ist definiert, ob cValue ausgeführt werden soll
        j2oValue = j2oRxStrings.replace(unicodeDecode(iVar), "$2")  'unicodeDecode(iVar)
    Else
        ref j2oValue, iVar
        If Not IsObject(j2oValue) Then
            If j2oParseIsoDate(j2oValue) Then
                ref j2oValue, cVal(unicodeDecode(j2oValue))
            End If
            If j2oRxStringsSingle.test(j2oValue) Then
                j2oValue = j2oRxStringsSingle.replace(j2oValue, "$2")
                j2oValue = unicodeDecode(j2oValue)
            End If
            j2oValue = cVal(j2oValue)
        End If
    End If
End Function
 
'/**
' * Parst das ISO-Datumsformat
' * ISO 8601 :standard: "2012-03-19T07:22Z".
' * @return Boolean
' */
Private Function j2oParseIsoDate(ByRef ioVar As Variant) As Boolean
    If trim(ioVar) = "" Then Exit Function
    If pJ2ORxDate Is Nothing Then Set pJ2ORxDate = cRx(json2obj_timestamp_pattern)
    If IsObject(ioVar) Or IsArray(ioVar) Or IsNull(ioVar) Then Exit Function
    j2oParseIsoDate = pJ2ORxDate.test(ioVar)
    If j2oParseIsoDate Then ioVar = pJ2ORxDate.replace(ioVar, json2obj_timestamp_replace)
End Function
 
'-------------------------------------------------------------------------------
' -- Public Properties
'-------------------------------------------------------------------------------
 
'/**
' * Das Format, in welchem ein reines Datum in den JSON geschrieben wird.
' * Standard: YYYY-MM-DD\T
' * @return String
'*/
Public Property Get obj2json_date_format() As String
    If pDateFormat = Empty Then pDateFormat = C_OBJ2JSON_DATE_FORMAT_DEFAULT
    obj2json_date_format = pDateFormat
End Property
Public Property Let obj2json_date_format(ByVal iFormat As String)
    pDateFormat = iFormat
End Property
 
'/**
' * Das Format, in welchem eine reine Zeit in den JSON geschrieben wird.
' * Standard: HH:NN:SS\Z
' * @return String
'*/
Public Property Get obj2json_time_format() As String
    If pTimeFormat = Empty Then pTimeFormat = C_OBJ2JSON_TIME_FORMAT_DEFAULT
    obj2json_time_format = pTimeFormat
End Property
Public Property Let obj2json_time_format(ByVal iFormat As String)
    pTimeFormat = iFormat
End Property
 
'/**
' * Das Format, in welchem ein reines Datum mit Zeit in den JSON geschrieben wird.
' * Standard: YYYY-MM-DD\THH:NN:SS\Z
' * @return String
'*/
Public Property Get obj2json_timestamp_format() As String
    If pTimeStampFormat = Empty Then pTimeStampFormat = C_OBJ2JSON_TIMESTAMP_FORMAT_DEFAULT
    obj2json_timestamp_format = pTimeStampFormat
End Property
Public Property Let obj2json_timestamp_format(ByVal iFormat As String)
    pTimeStampFormat = iFormat
End Property
 
'/**
' * Pattern zum Auslesen eines JSON-Datums.
' * Schreibweise siehe http://wiki.yaslaw.info/doku.php/vba/cast/cregexp
' * Muss zusammen mit json2obj_timestamp_replace einen gültigen Datumsstring ergeben (isDate(), cDate())
' * Standard: /^(?:(\d{4}-\d{2}-\d{2})T)?(?:(\d{2}:\d{2}:\d{2})Z)?$/i
' * @return String
'*/
Public Property Get json2obj_timestamp_pattern() As String
    If pTimeStampTemplate = Empty Then pTimeStampTemplate = C_JSON2OBJ_TIMESTAMP_PATTERN
    json2obj_timestamp_pattern = pTimeStampTemplate
End Property
Public Property Let json2obj_timestamp_pattern(ByVal iPattern As String)
    pTimeStampTemplate = iPattern
    Set pJ2ORxDate = Nothing
End Property
 
'/**
' * Replace zum Auslesen eines JSON-Datums.
' * Muss zusammen mit json2obj_timestamp_pattern einen gültigen Datumsstring ergeben (isDate(), cDate())
' * Standard: $1 $2
' * @return String
'*/
Public Property Get json2obj_timestamp_replace() As String
    If pTimeStampReplace = Empty Then pTimeStampReplace = C_JSON2OBJ_TIMESTAMP_REPLACE
    json2obj_timestamp_replace = pTimeStampReplace
End Property
Public Property Let json2obj_timestamp_replace(ByVal iReplace As String)
    pTimeStampReplace = iReplace
End Property
 
'-------------------------------------------------------------------------------
' -- Private Properties
'-------------------------------------------------------------------------------
'/**
' * Findet einen reinen Time-String
' * @retrun RegExp
' */
Private Property Get o2jRxTimeOnly() As Object
    Static rx As Object:    If rx Is Nothing Then Set rx = cRx("/^\d{2}:\d{2}:\d{2}$/i")
    Set o2jRxTimeOnly = rx
End Property
 
'/**
' * Ermittelt maskierte String und Datumsdelemiter
' * Da dieser RegExp innerhalb eines Loops mit replace() arbeitet, ist er nicht Global
' * @retrun RegExp
' */
Private Property Get j2oRxMaskedChars() As Object
    Static rx As Object:    If rx Is Nothing Then Set rx = cRx("/(['""#\\\[\]trn]\\)/")
    Set j2oRxMaskedChars = rx
End Property
 
 
'/**
' * Chars, welche innerhalb eines Strings stehen. Diese müssen in Unicode gewandelt werden
' * @retrun RegExp
' */
Private Property Get j2oRxCharsInStringToUnicode() As Object
    Static rx As Object:    If rx Is Nothing Then Set rx = cRx("/([\[\]\{\}'""#,:])/")
    Set j2oRxCharsInStringToUnicode = rx
End Property
 
'/**
' * Ermittelt Strings innerhlab eines JSON. '...' und "..."
' * @retrun RegExp
' */
Private Property Get j2oRxStrings() As Object
    Static rx As Object:    If rx Is Nothing Then Set rx = cRx("/(['""])([^\1]*?)\1/g")
    Set j2oRxStrings = rx
End Property
 
'/**
' * Ermittelt Strings innerhlab eines JSON. '...' und "..."
' * @retrun RegExp
' */
Private Property Get j2oRxStringsSingle() As Object
    Static rx As Object:    If rx Is Nothing Then Set rx = cRx("/^(['""])([^\1]*?)\1$/g")
    Set j2oRxStringsSingle = rx
End Property
'/**
' * RegEx um die Listen {..} und [...] zu finden
' * @retrun RegExp
' */
Private Property Get j2oRxParseList() As Object
    Static rx As Object:    If rx Is Nothing Then Set rx = cRx("/\s*(#A|#C|#D|)([\[\{])([^\[\{\]\}]*)[\]\}]/i")
    Set j2oRxParseList = rx
End Property
 
Private Function o2jUnicode2Mask(ByVal iString$, ByVal iEncodeParams As Long) As String
    Static rx As Object:    If rx Is Nothing Then Set rx = cRx("/(\\u00(?:0D|0A|09|28|05B|05D|07B|07D|023|02C|03A|02))/i")
 
    o2jUnicode2Mask = iString
 
    If Not andB(iEncodeParams, jqmUnicodeInsteadOfMask) Then
        Do While rx.test(o2jUnicode2Mask)
            Dim m: Set m = rx.execute(o2jUnicode2Mask)(0)
            o2jUnicode2Mask = rx.replace(o2jUnicode2Mask, o2jDictJsonSpezChars(m.value))
        Loop
        If andB(iEncodeParams, jqmSingleQuote) Then
            o2jUnicode2Mask = replace(o2jUnicode2Mask, "\u0027", "\'")
        Else
            o2jUnicode2Mask = replace(o2jUnicode2Mask, "\u0022", "\""")
        End If
 
    End If
 
End Function
 
Private Property Get o2jDictJsonSpezChars() As Object
    Static dict As Object
    If dict Is Nothing Then
        Set dict = CreateObject("scripting.Dictionary")
        dict.add "\u000A", "\n"         'new Line
        dict.add "\u000D", "\r"         'carige return
        dict.add "\u0009", "\t"         'Tab
        dict.add "\u0027", "\'"
        dict.add "\u0028", "\("
        dict.add "\u005B", "\["
        dict.add "\u005D", "\]"
        dict.add "\u007B", "\{"
        dict.add "\u007D", "\}"
        dict.add "\u0022", "\"""
        dict.add "\u0023", "\#"
        dict.add "\u002C", "\,"
        dict.add "\u003A", "\:"
        dict.add "\u0029", "\)"
    End If
    Set o2jDictJsonSpezChars = dict
End Property
 
Private Property Get j2oDictJsonSpezChars() As Object
    Static dict As Object
    If dict Is Nothing Then
        Set dict = CreateObject("scripting.Dictionary")
        Dim keys:   keys = o2jDictJsonSpezChars.keys
        Dim k: For Each k In keys
            dict.add o2jDictJsonSpezChars(k), k
        Next k
    End If
    Set j2oDictJsonSpezChars = dict
End Property
 
'-------------------------------------------------------------------------------
' -- Private Methodes
'-------------------------------------------------------------------------------
 
'Entfernt tab,formfeed, return und new Line aus einem String
Private Function removeSpaces(ByVal iString As String) As String
    Static rx As Object:    If rx Is Nothing Then Set rx = cRx("/[\u0000\f\t\n\r]/g")
    removeSpaces = rx.replace(iString, "")
End Function
 
Private Function extractString(ByVal iString As String) As String
    Static rx As Object:    If rx Is Nothing Then Set rx = cRx("/^([""'])?(.*)?\1$/")
    extractString = rx.replace(iString, "$2")
End Function
 
'/**
' * Copyright mpl by ERB software | http://wiki.yaslaw.info
' *
' * Wandelt ein Unicode in ein Charakter
' * @example: unicode2char("\u20AC") -> '\€'
' * @param  String      Unicode
' * @return String      Char
' */
Private Function unicode2Char(ByVal iUnicode As String) As String
    unicode2Char = ChrW(replace(iUnicode, "\u", "&h"))
End Function
 
'/**
' * Copyright mpl by ERB software | http://wiki.yaslaw.info
' *
' * Wandelt ein Charakter in ein Unicode
' * @example: char2unicode("€") -> '\u20AC'
' * @param  String(1)   Charakter, der gewandelt werden soll
' * @return String      Unicode
' */
Private Function char2unicode(ByVal iChar As String) As String
    char2unicode = Hex(AscW(iChar)) 'Hex-Wert ermitteln
    char2unicode = "\u" & String(4 - Len(char2unicode), "0") & char2unicode
End Function
 
'vbTab, vbLf, vbCr, vbFormFeed, ":", ",", """", "'"
'Sonderzeichen ausserhalb Ascii 32 bis 127 ersetzen. Leerzeichen nicht ersetzen (\u0020d). Dafür den aktive Delemiter ersetzen
Private Function unicodeSpezChars(ByVal iString) As String
    unicodeSpezChars = iString
    Static lastQm As String
'    Static rx As Object: If rx Is Nothing Or stringDelemiter <> lastQm Then Set rx = cRx("/(" & stringDelemiter & "|[^\u0021-\u007e\u0020d]|[\u003a])/i")
    Static rx As Object: If rx Is Nothing Or stringDelemiter <> lastQm Then Set rx = cRx("/(" & stringDelemiter & "|[^\u0021-\u007e\u0020d])/i")
    lastQm = stringDelemiter
    Do While rx.test(unicodeSpezChars)
        unicodeSpezChars = rx.replace(unicodeSpezChars, char2unicode(rx.execute(unicodeSpezChars)(0).subMatches(0)))
    Loop
End Function
 
'/**
' * Wandelt alle Unicodes in einem String in das eigentliche Zeichen zurück
' * @param  String
' * @return String
' */
Private Function unicodeDecode(ByVal iString) As String
    unicodeDecode = iString
    Static rx As Object
    If rx Is Nothing Then Set rx = cRx("/\\u[0-9A-F]{4}/i")
    Do While rx.test(unicodeDecode)
        unicodeDecode = rx.replace(unicodeDecode, unicode2Char(rx.execute(unicodeDecode)(0)))
    Loop
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 + 1)
End Function
 
 
'/**
' * Dito zu cDict(). Die Übergabe ist aber nicht ein ParamArray sondern ein Arry.
' * Spezielle ANpassung für json2Obj
' * Dieser Aufruf wird vor allem im Einsatz in anderen Funktionen verwendet
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cdic
' * V3.1.3
' * @param  Array
' * @return Dictionary
' */
Private Function cDictAJson(Optional ByRef iItems As Variant) As Object
    'Cache RegExp um einSet-String zu zerlegen
    Static rxSetString As Object:               If rxSetString Is Nothing Then Set rxSetString = cRx("/(?:\s*,\s*)?(?!\\)(|lluN|eslaf|eurt|(['""#](?![\\,])).+?\1(?!\\)|[\d\.]*|.*?)\s*(?:>=|[:=])\s*((['""](?!\\)).+?\4(?!\\)|(\](?!\\)).+?\[(?!\\)|[\w\s-]+\b)/ig")
    Static rxCharsInStringToUnicode As Object:  If rxCharsInStringToUnicode Is Nothing Then Set rxCharsInStringToUnicode = cRx("/([\[\]\{\}'""=;,:])/")
    Static rxStrings As Object:                 If rxStrings Is Nothing Then Set rxStrings = cRx("/(['""#])([^\1]*?)\1/g")
    Set cDictAJson = CreateObject("scripting.Dictionary")
    Dim mc As Object
    Dim items() As Variant:                     items = CVar(iItems)
    Dim 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
            Dim keys() As Variant:      keys = items(0)
            Dim values() As Variant:    values = items(1)
            Dim delta As Long:          delta = LBound(keys) - LBound(values)
            ReDim Preserve values(LBound(values) To UBound(keys) + delta)
            Dim i As Integer: For i = LBound(keys) To UBound(keys)
                If Not cDictAJson.exists(keys(i)) Then cDictAJson.add keys(i), values(i + delta)
            Next i
            Exit Function
        End If
    End If
 
    'Alle Items durchackern
    Dim cnt As Integer:     cnt = 0
    Dim item As Variant:    For Each item In items
        'Dictionary
        If Not isList And TypeName(item) = "Dictionary" Then
            For Each key In item.keys
                If Not cDictAJson.exists(key) Then cDictAJson.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 cDictAJson.exists(key) Then cDictAJson.add key, item(key)
            Next key
        'SetString
        ElseIf Not isList And Not IsArray(item) And Not IsObject(item) Then
            'Alle []{}'"=;, innerhalb eines Strings in Unicode parsen
            If rxStrings.test(item) Then
                Set mc = rxStrings.execute(item)
                For i = mc.count - 1 To 0 Step -1
                    Dim substr As String: substr = mc(i).subMatches(1)
                    Do While rxCharsInStringToUnicode.test(substr)
                        substr = rxCharsInStringToUnicode.replace(substr, CStr(char2unicode(rxCharsInStringToUnicode.execute(substr)(0))))
                    Loop
                    Dim dm As String: dm = mc(i).subMatches(0)
                    item = replaceIndex(item, dm & substr & dm, mc(i).firstIndex, mc(i).Length)
                Next i
            End If
            If rxSetString.test(StrReverse(item)) Then
                Set mc = rxSetString.execute(StrReverse(item))
                Dim k As Variant: For k = mc.count - 1 To 0 Step -1
                    key = extractString(unicodeDecode(StrReverse(mc(k).subMatches(2))))
                    'value = extractString(unicodeDecode(StrReverse(mc(k).subMatches(0))))
                    value = unicodeDecode(StrReverse(mc(k).subMatches(0)))
                    If Not cDictAJson.exists(key) Then cDictAJson.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 cnt = 0 Or isList Then
default:
            If cnt Mod 2 = 0 Then
                key = item
            ElseIf Not cDictAJson.exists(key) Then cDictAJson.add key, item
            End If
            isList = True
        End If
        cnt = cnt + 1
    Next
    'Falls es sich um eine nicht abgeschlossene Liste handelt
    'JSON: Key als Nummer und KEY als Wert
    If isList And cnt Mod 2 <> 0 Then
        If Not cDictAJson.exists(key) Then
            cDictAJson.add key, key
        Else
            Dim idx As Integer: idx = 0
            Do While cDictAJson.exists(idx)
                idx = idx + 1
            Loop
            cDictAJson.add idx, key
        End If
    End If
End Function
 
'-------------------------------------------------------------------------------
'-- LIBRARIES
'-------------------------------------------------------------------------------
'/**
' * PreIncrement    ++i
' * Zählt i eins hoch und gibt den Wert zurück
' * V1.0.0
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/increment
' * @param  Number
' * @retrun Number
' */
Private Function inc(ByRef i As Variant) As Variant
    i = i + 1:  inc = i
End Function
 
'/**
' * Version 1.3.0
' * Es wird versucht, den Paramter in seine eigentlichen Typ zu wandeln. Gar mit Textausgaben oder parsen von SQL interessant
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cval
' * @example    cVal("Null") -> Null, cVal("True") -> -1, cVal("time") -> 15:08:37
' * @param  Variant
' * @return Variant
' */
Private Function cVal(ByVal iValue As Variant) As Variant
On Error Resume Next
#If ms_product = C_ACCESS Then
    Set cVal = iValue: cVal = iValue:  cVal = Eval(iValue)
#Else
    Set cVal = iValue: cVal = iValue: cVal = CDbl(iValue): cVal = CLng(iValue): cVal = CInt(iValue)
    cVal = IIf(UCase(iValue) = "NULL", Null, cVal)
#End If
    If IsDate(iValue) Then cVal = CDate(iValue)
    Select Case UCase(iValue)
        Case "EMPTY":       cVal = Empty
        Case "NOTHING":     Set cVal = Nothing
        Case "FALSE":       cVal = False
        Case "TRUE":        cVal = True
    End Select
    'Falls der TExt einem reservierten Wort entspricht, fällt eval auf den Kopf. Darum direkt mappen
    If reservedWords.exists(UCase(iValue)) Then ref cVal, iValue
End Function
'Für cVal angepasste Version, Folgende Items entfernt: False, True, Null, Nothing, Empty
Private Property Get reservedWords() As Object
    'https://bettersolutions.com/vba/syntax/keywords.htm um 'name' ergänzt
    Const C_RWORDS$ = "#If,#Else,#Else If,#End If,#Const,Alias,And,As,Base,Boolean,Byte,ByRef,ByVal," & _
        "Call,Case,CBool,CByte,CCur,CDate,CDbl,CInt,CLng,CLngLng,CLngPtr,Compare,Const,CSng,CStr,Currency,Var," & _
        "Database,Date,Declare,DefBool,DefByte,DefDate,DefDec,DefDouble,DefInt,DefLng,DefLngLng,DefLngPtr,DefObj,DefSng,DefStr,Dim,Do,Double," & _
        "Each,Else,ElseIf,End,Enum,Erse,Error,Event,Exit,Explicit,For,Friend,Function,Get,Global,GoTo,If,IIf,Implements,Integer,Is," & _
        "Let,LBound,Lib,Like,Long,LongLong,Loop,LSet,Me,Mod,Name,New,Next,Not,Object,On,Option,Optional,Or," & _
        "ParamArray,Preserve,Private,Property,Public,RaiseEvent,ReDim,Resume,Return,RSet,Select,Set,Single,Static,Step,Stop,String,Sub," & _
        "Text,ThenTo,Type,TypeOf,UBound,Until,Variant,Wend,While,With,WithEvents"
    Static dict As Object
    If dict Is Nothing Then
        Set dict = CreateObject("scripting.Dictionary")
        Dim rWordsArr$(): rWordsArr = Split(UCase(C_RWORDS), ",")
        Dim i&: For i = 0 To UBound(rWordsArr)
            dict.add trim(rWordsArr(i)), True
        Next i
    End If
    Set reservedWords = dict
End Property
 
'/**
' * Bei einer Variablenübergabe muss immer unterscheiden werden, ob es ein Objekt ist oder nicht.
' * Diese Sub nimmt einem die Arbeit ab
' * oNode = iNode
' * @param  Variant     Variable, die den Wert bekommen soll
' * @param  Variant     Ret Wert selber
' */
Private Sub ref(ByRef oNode As Variant, ByRef iNode As Variant)
    If IsObject(iNode) Then
        'Objekte als referenz übergeben
        Set oNode = iNode
    Else
        oNode = iNode
    End If
End Sub
 
'/**
' * 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      RegExp-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://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/andb
' * Macht einen Bit-Vergleich
' * @param  Long
' * @param  Long
' * @return Boolean
' */
Private Function andB(ByVal iHaystack As Long, ByVal iNeedle As Long) As Boolean
    andB = ((iHaystack And iNeedle) = iNeedle)
End Function
 
#If IS_ACCESS = False 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