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.0.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 gaeparst werden soll
'               13.10.2014 - ERS - Cache auf Dictionary und Properties umgestellt, replaceA auf strReplace umgestellt sowie div. weitere Umstellungen
'               12.11.2014 - ERS - Decode-Paramater jrtNotCastValue hinzugefügt. Es verhindert das automatische cast() der Values
'               22.11.2014 - ERS - Rundumerneuert. Erkenntnisse des letzten halben Jahres.
'
'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
    jrtNotCastValue = 2 ^ 4 'cast der Values verhindern
    jrtEmptyList = 2 ^ 5    'Angabe, ob bei einem Leeren String eine Collection/Array/Dictionary zurückgegeben werden soll
    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
    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"
Private Const C_TIME_F = "\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 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 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 Cache
'-------------------------------------------------------------------------------

'/**
' * Lokaler Cache
' */


'-------------------------------------------------------------------------------
' 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 j2oParams As jsonDecodeParams = jrtDefault, Optional ByRef oObj As Variant) As Variant
'    Call parse(iString, j2oParams, 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
    o2jParams = iEncodeParams
    stringDelemiter = IIf(iEncodeParams = jqmDoubleQuote, """", "'")
    
    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 = o2jRekursive(iObj)
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)
    '[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(ByRef 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
    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 Not o2jRxTimeOnly.test(CStr(iVar)) Then o2jValue = format(iVar, C_DATE_F)
        If Not (hour(iVar) + minute(iVar) + second(iVar)) = 0 Then o2jValue = o2jValue & format(iVar, C_TIME_F)
    '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
        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
' * @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) As Variant
    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))))
    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( _
                            sm(1) = "{", jrtDictionary, _
                            (j2oParams And jrtCollection), jrtCollection, _
                            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))
        End Select
        'Liste im JSON durch den Key ersetzen
        str = j2oRxParseList.Replace(str, key)
    Loop
    'Der Letzte Inhalt des contents entspricht der json2obj
    ref json2obj, contents(key)
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 jrtEmptyList Then
        If j2oParams And jrtDictionary Then
            Set oList = CreateObject("scripting.Dictionary")
        ElseIf j2oParams And jrtCollection Then
            Set oList = New Collection
        Else
            oList = Array()
        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, list(k))
    Next k
    j2oArray = retArr
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
    Set j2oCollection = New Collection
    Dim arr As Variant: arr = Split(iListString, ",")
    Dim k As Integer: For k = 0 To UBound(arr)
        j2oCollection.add j2oValue(iContents, arr(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) As Object
    Dim list As Object: Set list = cDictAJson(Array(CStr(iListString)))
    Set j2oDict = CreateObject("scripting.Dictionary")
    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 = unicodeDecode(iVar)
    Else
        j2oValue = cValue(unicodeDecode(iVar))
    End If
End Function

'/**
' * 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

'-------------------------------------------------------------------------------
' -- 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 = cRegExp("/^\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 = cRegExp("/(['""#])\\/")
    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 = cRegExp("/([\[\]\{\}'""#,])/")
    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 = cRegExp("/(['""])([^'""]+?)\1/g")
    Set j2oRxStrings = 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 = cRegExp("/(#A|#C|#D|)([\[\{])([^\[\{\]\}]*)[\]\}]/i")
    Set j2oRxParseList = rx
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 = cRegExp("/[\u0000\f\t\n\r]/")
    removeSpaces = rx.Replace(iString, "")
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, ":", ",", """", "'"
Private Function unicodeSpezChars(ByVal iString) As String
    unicodeSpezChars = iString
    Static rx As Object
    Static lastQm As String
    'Sonderzeichen ausserhalb Ascii 32 bis 127 ersetzen. Leerzeichen nicht ersetzen (\u0020d). Dafür den aktive Delemiter ersetzen
    If rx Is Nothing Or stringDelemiter <> lastQm Then Set rx = cRegExp("/(" & stringDelemiter & "|[^\u0021-\u007e\u0020d])/")
    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 = cRegExp("/\\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.1
' * @param  Array
' * @return Dictionary
' */
Public Function cDictAJson(Optional ByRef iItems As Variant) As Object
    Static rxSetString As Object    'Cache RegExp um einSet-String zu zerlegen
    Set cDictAJson = CreateObject("scripting.Dictionary")
    If IsMissing(iItems) Then Exit Function
    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
        '
        
            If rxSetString Is Nothing Then Set rxSetString = cRegExp("/(lluN|(['""#](?![\\,])).+?\1(?!\\)|[\d\.]*)\s*(?:>=|[:=])\s*((['""](?!\\)).+?\4(?!\\)|(\](?!\\)).+?\[(?!\\)|[\w\s-]+)/gi")
            If rxSetString.test(StrReverse(item)) Then
                Dim mc As Object: Set mc = rxSetString.execute(StrReverse(item))
                Dim k As Variant: For k = mc.count - 1 To 0 Step -1
                    key = StrReverse(mc(k).subMatches(2))
                    value = StrReverse(mc(k).subMatches(0))
                    'key = cValue(StrReverse(mc(k).subMatches(2)))
                    'value = cValue(StrReverse(mc(k).subMatches(0)), cvhNullTextAsNull)
                    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
    If isList And cnt Mod 2 <> 0 Then
        If Not cDictAJson.exists(key) Then cDictAJson.add key, Empty
    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

'/**
' * Castet ein String in was auch immer (Integer, Long, Date etc.)
' * Datum in #..# oder Strings in '..',".." und [..] können geparst werden
' * V1.0.0 - Abgeänderte Form. Datum-String im JSON-Format
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cvalue
' * @param  String
' * @return Varaint
' */
Private Function cValue(ByVal iString As String, Optional ByVal iHandling As cvHandling) As Variant
    Static rxDateString As Object
    Static rxDelemitedString As Object
    Dim sm As Object
    
    'Den Datentyp über das Ausschlussverfahren ermitteln
    On Error Resume Next
    
    If iHandling And cvhNullTextAsNull And UCase(iString) = "NULL" Then
        cValue = Null
        Exit Function
    End If
    If iHandling And cvhEmptyAsNull And iString = Empty Then
        cValue = Null
        Exit Function
    End If
    
    'Nummern
    If IsNumeric(iString) Then
        cValue = CByte(iString):    If cValue = iString Then Exit Function
        cValue = CInt(iString):     If cValue = iString Then Exit Function
        cValue = CLng(iString):     If cValue = iString Then Exit Function
        cValue = CDbl(iString):     If cValue = iString Then Exit Function
        cValue = CDec(iString):     Exit Function
    End If
    
    'Boolean
    Err.Clear
    cValue = CBool(iString):    If Err.Number = 0 Then Exit Function
    
    'Datum
    If IsDate(iString) Then
        cValue = CDate(iString)
        Exit Function
    End If
    
    Static rxDate As Object
    If rxDate Is Nothing Then Set rxDate = cRegExp("/^(\d{4}-\d{2}-\d{2})?(?:T(\d{2}:\d{2}:\d{2}))?$/i")
    If rxDate.test(iString) Then
        Set sm = rxDate.execute(iString)(0).subMatches
        If sm(0) <> Empty Then cValue = CDate(sm(0))
        If sm(1) <> Empty Then cValue = cValue + CDate(sm(1))
        Exit Function
    End If
    
    'String in Delemiter
    If rxDelemitedString Is Nothing Then Set rxDelemitedString = cRegExp("/^[#""'\[](.*)([""'#\]])$/") '0: String ohne Delemiter, 1: End-Delemiter: '," oder ]
    If rxDelemitedString.test(iString) Then
        Set sm = rxDelemitedString.execute(iString)(0).subMatches
        cValue = Replace(sm(0), "\" & sm(1), sm(1))
        Exit Function
    End If
    'String 1 zu 1 zurückgeben
    cValue = iString
    On Error GoTo 0
End Function

'/**
' * Erstellt ein RegExp-Object mit den Grundeinstellungen
' * V2.0.1
' * @param  String          Pattern mit Delmiter und igm-Parametern
' * @return RegExp
' */
Private Function cRegExp(ByVal iPattern As String) As Object
    Static rxP As Object                            'RegExpo um iPattern aufzubrechen
    If rxP Is Nothing Then
        Set rxP = CreateObject("VBScript.RegExp")
        rxP.pattern = "^([@&!/~#=\|])(.*)\1(?:([Ii])|([Gg])|([Mm]))*$"
    End If
    Set cRegExp = CreateObject("VBScript.RegExp")   'Neuer RegExp erstellen
    If Not rxP.test(iPattern) Then cRegExp.pattern = iPattern: Exit Function    'Falls es ein einfacher Pattern ist, diesen übernehmen und die Func verlassen
    Dim parts As Object: Set parts = rxP.execute(iPattern)(0).subMatches        'Pattern zerlegen. 0) Delemiter, 1) Pattern, 2) - 4) Paramters
    cRegExp.IgnoreCase = Not isEmpty(parts(2))
    cRegExp.Global = Not isEmpty(parts(3))
    cRegExp.Multiline = Not isEmpty(parts(4))
    cRegExp.pattern = parts(1)
End Function