Analysieren von JSON in Excel VBA

Ich habe das gleiche Problem wie in Excel VBA: Analysierte JSON-Objektschleife , kann jedoch keine Lösung finden. Mein JSON hat verschachtelte Objekte, daher funktionieren Lösungsvorschläge wie VBJSON und vba-json für mich nicht. Ich habe auch einen Fehler behoben, der ordnungsgemäß funktioniert, aber das Ergebnis war ein Überlauf des Aufrufstapels aufgrund zu vieler Rekursionen der Funktion doProcess.

Die beste Lösung scheint die jsonDecode-Funktion zu sein, die im ursprünglichen Beitrag zu sehen ist. Es ist sehr schnell und sehr effektiv; Meine Objektstruktur befindet sich in einem generischen VBA-Objekt vom Typ JScriptTypeInfo.

Das Problem an dieser Stelle ist, dass ich nicht bestimmen kann, wie die Objekte strukturiert sein werden. Daher kenne ich die Schlüssel, die sich in den einzelnen generischen Objekten befinden, nicht im Voraus. Ich muss das generische VBA-Objekt durchlaufen, um die Schlüssel / Eigenschaften zu erhalten.

Wenn meine Parsing-Javascript-Funktion eine VBA-Funktion oder ein Sub auslösen könnte, wäre das ausgezeichnet.

Wenn Sie darauf aufbauen möchten ScriptControl, können Sie einige Hilfsmethoden hinzufügen, um die erforderlichen Informationen zu erhalten. Das JScriptTypeInfoObjekt ist etwas unglücklich: Es enthält alle relevanten Informationen (wie Sie im Überwachungsfenster sehen können), aber es scheint unmöglich, mit VBA darauf zuzugreifen. Die Javascript-Engine kann uns jedoch helfen:

Option Explicit

Private ScriptEngine As ScriptControl

Public Sub InitScriptEngine()
    Set ScriptEngine = New ScriptControl
    ScriptEngine.Language = "JScript"
    ScriptEngine.AddCode "function getProperty(jsonObj, propertyName) { return jsonObj[propertyName]; } "
    ScriptEngine.AddCode "function getKeys(jsonObj) { var keys = new Array(); for (var i in jsonObj) { keys.push(i); } return keys; } "
End Sub

Public Function DecodeJsonString(ByVal JsonString As String)
    Set DecodeJsonString = ScriptEngine.Eval("(" + JsonString + ")")
End Function

Public Function GetProperty(ByVal JsonObject As Object, ByVal propertyName As String) As Variant
    GetProperty = ScriptEngine.Run("getProperty", JsonObject, propertyName)
End Function

Public Function GetObjectProperty(ByVal JsonObject As Object, ByVal propertyName As String) As Object
    Set GetObjectProperty = ScriptEngine.Run("getProperty", JsonObject, propertyName)
End Function

Public Function GetKeys(ByVal JsonObject As Object) As String()
    Dim Length As Integer
    Dim KeysArray() As String
    Dim KeysObject As Object
    Dim Index As Integer
    Dim Key As Variant

    Set KeysObject = ScriptEngine.Run("getKeys", JsonObject)
    Length = GetProperty(KeysObject, "length")
    ReDim KeysArray(Length - 1)
    Index = 0
    For Each Key In KeysObject
        KeysArray(Index) = Key
        Index = Index + 1
    Next
    GetKeys = KeysArray
End Function


Public Sub TestJsonAccess()
    Dim JsonString As String
    Dim JsonObject As Object
    Dim Keys() As String
    Dim Value As Variant
    Dim j As Variant

    InitScriptEngine

    JsonString = "{""key1"": ""val1"", ""key2"": { ""key3"": ""val3"" } }"
    Set JsonObject = DecodeJsonString(CStr(JsonString))
    Keys = GetKeys(JsonObject)

    Value = GetProperty(JsonObject, "key1")
    Set Value = GetObjectProperty(JsonObject, "key2")
End Sub

Ein paar Anmerkungen:

• Wenn die JScriptTypeInfoInstanz auf ein Javascript-Objekt verweist, For Each ... Nextfunktioniert dies nicht. Es funktioniert jedoch, wenn es sich auf ein Javascript-Array bezieht (siehe GetKeysFunktion).
• Die Zugriffseigenschaften, deren Name nur zur Laufzeit bekannt ist, verwenden die Funktionen GetPropertyund GetObjectProperty.
• Die Javascript - Array bietet die Eigenschaften length, 0, Item 0, 1, Item 1etc. Mit der VBA Punktnotation ( jsonObject.property), nur die Länge Eigenschaft ist zugänglich und nur dann , wenn Sie eine Variable deklarieren genannt lengthmit Kleinbuchstaben. Andernfalls stimmt der Fall nicht überein und wird nicht gefunden. Die anderen Eigenschaften sind in VBA nicht gültig. Also besser die GetPropertyFunktion nutzen.
• Der Code verwendet eine frühe Bindung. Sie müssen also einen Verweis auf "Microsoft Script Control 1.0" hinzufügen.
• Sie müssen InitScriptEngineeinmal aufrufen , bevor Sie die anderen Funktionen verwenden können, um eine grundlegende Initialisierung durchzuführen.

UPDATE 3 (24. September 17)

Überprüfen Sie den VBA-JSON-Parser auf GitHub auf die neueste Version und Beispiele. Importieren Sie das Modul JSON.bas in das VBA-Projekt für die JSON-Verarbeitung .

UPDATE 2 (1. Oktober 16)

Allerdings , wenn Sie nicht möchten , JSON auf 64-Bit - Office analysieren mit ScriptControl, dann diese Antwort kann Ihnen helfen, zu erhalten , ScriptControlum die Arbeit an 64-Bit.

UPDATE (26. Oktober 15)

Beachten Sie, dass a- ScriptControlbasierte Ansätze das System in einigen Fällen anfällig machen, da sie einen direkten Zugriff auf die Laufwerke (und andere Inhalte) für den schädlichen JS-Code über ActiveX ermöglichen. Angenommen, Sie analysieren die JSON-Antwort des Webservers wie JsonString = "{a:(function(){(new ActiveXObject('Scripting.FileSystemObject')).CreateTextFile('C:\\Test.txt')})()}". Nach der Auswertung finden Sie eine neu erstellte Datei C:\Test.txt. Daher ist das Parsen von JSON mit ScriptControlActiveX keine gute Idee.

Um dies zu vermeiden, habe ich einen JSON-Parser basierend auf RegEx erstellt. Objekte {}werden durch Wörterbücher dargestellt, das möglich macht , Wörterbuch der Eigenschaften und Methoden zu verwenden: .Count, .Exists(), .Item(), .Items, .Keys. Arrays []sind die herkömmlichen VB-Arrays auf Nullbasis und zeigen daher UBound()die Anzahl der Elemente an. Hier ist der Code mit einigen Verwendungsbeispielen:

Option Explicit

Sub JsonTest()
    Dim strJsonString As String
    Dim varJson As Variant
    Dim strState As String
    Dim varItem As Variant

    ' parse JSON string to object
    ' root element can be the object {} or the array []
    strJsonString = "{""a"":[{}, 0, ""value"", [{""stuff"":""content""}]], b:null}"
    ParseJson strJsonString, varJson, strState

    ' checking the structure step by step
    Select Case False ' if any of the checks is False, the sequence is interrupted
        Case IsObject(varJson) ' if root JSON element is object {},
        Case varJson.Exists("a") ' having property a,
        Case IsArray(varJson("a")) ' which is array,
        Case UBound(varJson("a")) >= 3 ' having not less than 4 elements,
        Case IsArray(varJson("a")(3)) ' where forth element is array,
        Case UBound(varJson("a")(3)) = 0 ' having the only element,
        Case IsObject(varJson("a")(3)(0)) ' which is object,
        Case varJson("a")(3)(0).Exists("stuff") ' having property stuff,
        Case Else
            MsgBox "Check the structure step by step" & vbCrLf & varJson("a")(3)(0)("stuff") ' then show the value of the last one property.
    End Select

    ' direct access to the property if sure of structure
    MsgBox "Direct access to the property" & vbCrLf & varJson.Item("a")(3)(0).Item("stuff") ' content

    ' traversing each element in array
    For Each varItem In varJson("a")
        ' show the structure of the element
        MsgBox "The structure of the element:" & vbCrLf & BeautifyJson(varItem)
    Next

    ' show the full structure starting from root element
    MsgBox "The full structure starting from root element:" & vbCrLf & BeautifyJson(varJson)

End Sub

Sub BeautifyTest()
    ' put sourse JSON string to "desktop\source.json" file
    ' processed JSON will be saved to "desktop\result.json" file
    Dim strDesktop As String
    Dim strJsonString As String
    Dim varJson As Variant
    Dim strState As String
    Dim strResult As String
    Dim lngIndent As Long

    strDesktop = CreateObject("WScript.Shell").SpecialFolders.Item("Desktop")
    strJsonString = ReadTextFile(strDesktop & "\source.json", -2)
    ParseJson strJsonString, varJson, strState
    If strState <> "Error" Then
        strResult = BeautifyJson(varJson)
        WriteTextFile strResult, strDesktop & "\result.json", -1
    End If
    CreateObject("WScript.Shell").PopUp strState, 1, , 64
End Sub

Sub ParseJson(ByVal strContent As String, varJson As Variant, strState As String)
    ' strContent - source JSON string
    ' varJson - created object or array to be returned as result
    ' strState - Object|Array|Error depending on processing to be returned as state
    Dim objTokens As Object
    Dim objRegEx As Object
    Dim bMatched As Boolean

    Set objTokens = CreateObject("Scripting.Dictionary")
    Set objRegEx = CreateObject("VBScript.RegExp")
    With objRegEx
        ' specification http://www.json.org/
        .Global = True
        .MultiLine = True
        .IgnoreCase = True
        .Pattern = """(?:\\""|[^""])*""(?=\s*(?:,|\:|\]|\}))"
        Tokenize objTokens, objRegEx, strContent, bMatched, "str"
        .Pattern = "(?:[+-])?(?:\d+\.\d*|\.\d+|\d+)e(?:[+-])?\d+(?=\s*(?:,|\]|\}))"
        Tokenize objTokens, objRegEx, strContent, bMatched, "num"
        .Pattern = "(?:[+-])?(?:\d+\.\d*|\.\d+|\d+)(?=\s*(?:,|\]|\}))"
        Tokenize objTokens, objRegEx, strContent, bMatched, "num"
        .Pattern = "\b(?:true|false|null)(?=\s*(?:,|\]|\}))"
        Tokenize objTokens, objRegEx, strContent, bMatched, "cst"
        .Pattern = "\b[A-Za-z_]\w*(?=\s*\:)" ' unspecified name without quotes
        Tokenize objTokens, objRegEx, strContent, bMatched, "nam"
        .Pattern = "\s"
        strContent = .Replace(strContent, "")
        .MultiLine = False
        Do
            bMatched = False
            .Pattern = "<\d+(?:str|nam)>\:<\d+(?:str|num|obj|arr|cst)>"
            Tokenize objTokens, objRegEx, strContent, bMatched, "prp"
            .Pattern = "\{(?:<\d+prp>(?:,<\d+prp>)*)?\}"
            Tokenize objTokens, objRegEx, strContent, bMatched, "obj"
            .Pattern = "\[(?:<\d+(?:str|num|obj|arr|cst)>(?:,<\d+(?:str|num|obj|arr|cst)>)*)?\]"
            Tokenize objTokens, objRegEx, strContent, bMatched, "arr"
        Loop While bMatched
        .Pattern = "^<\d+(?:obj|arr)>$" ' unspecified top level array
        If Not (.Test(strContent) And objTokens.Exists(strContent)) Then
            varJson = Null
            strState = "Error"
        Else
            Retrieve objTokens, objRegEx, strContent, varJson
            strState = IIf(IsObject(varJson), "Object", "Array")
        End If
    End With
End Sub

Sub Tokenize(objTokens, objRegEx, strContent, bMatched, strType)
    Dim strKey As String
    Dim strRes As String
    Dim lngCopyIndex As Long
    Dim objMatch As Object

    strRes = ""
    lngCopyIndex = 1
    With objRegEx
        For Each objMatch In .Execute(strContent)
            strKey = "<" & objTokens.Count & strType & ">"
            bMatched = True
            With objMatch
                objTokens(strKey) = .Value
                strRes = strRes & Mid(strContent, lngCopyIndex, .FirstIndex - lngCopyIndex + 1) & strKey
                lngCopyIndex = .FirstIndex + .Length + 1
            End With
        Next
        strContent = strRes & Mid(strContent, lngCopyIndex, Len(strContent) - lngCopyIndex + 1)
    End With
End Sub

Sub Retrieve(objTokens, objRegEx, strTokenKey, varTransfer)
    Dim strContent As String
    Dim strType As String
    Dim objMatches As Object
    Dim objMatch As Object
    Dim strName As String
    Dim varValue As Variant
    Dim objArrayElts As Object

    strType = Left(Right(strTokenKey, 4), 3)
    strContent = objTokens(strTokenKey)
    With objRegEx
        .Global = True
        Select Case strType
            Case "obj"
                .Pattern = "<\d+\w{3}>"
                Set objMatches = .Execute(strContent)
                Set varTransfer = CreateObject("Scripting.Dictionary")
                For Each objMatch In objMatches
                    Retrieve objTokens, objRegEx, objMatch.Value, varTransfer
                Next
            Case "prp"
                .Pattern = "<\d+\w{3}>"
                Set objMatches = .Execute(strContent)

                Retrieve objTokens, objRegEx, objMatches(0).Value, strName
                Retrieve objTokens, objRegEx, objMatches(1).Value, varValue
                If IsObject(varValue) Then
                    Set varTransfer(strName) = varValue
                Else
                    varTransfer(strName) = varValue
                End If
            Case "arr"
                .Pattern = "<\d+\w{3}>"
                Set objMatches = .Execute(strContent)
                Set objArrayElts = CreateObject("Scripting.Dictionary")
                For Each objMatch In objMatches
                    Retrieve objTokens, objRegEx, objMatch.Value, varValue
                    If IsObject(varValue) Then
                        Set objArrayElts(objArrayElts.Count) = varValue
                    Else
                        objArrayElts(objArrayElts.Count) = varValue
                    End If
                    varTransfer = objArrayElts.Items
                Next
            Case "nam"
                varTransfer = strContent
            Case "str"
                varTransfer = Mid(strContent, 2, Len(strContent) - 2)
                varTransfer = Replace(varTransfer, "\""", """")
                varTransfer = Replace(varTransfer, "\\", "\")
                varTransfer = Replace(varTransfer, "\/", "/")
                varTransfer = Replace(varTransfer, "\b", Chr(8))
                varTransfer = Replace(varTransfer, "\f", Chr(12))
                varTransfer = Replace(varTransfer, "\n", vbLf)
                varTransfer = Replace(varTransfer, "\r", vbCr)
                varTransfer = Replace(varTransfer, "\t", vbTab)
                .Global = False
                .Pattern = "\\u[0-9a-fA-F]{4}"
                Do While .Test(varTransfer)
                    varTransfer = .Replace(varTransfer, ChrW(("&H" & Right(.Execute(varTransfer)(0).Value, 4)) * 1))
                Loop
            Case "num"
                varTransfer = Evaluate(strContent)
            Case "cst"
                Select Case LCase(strContent)
                    Case "true"
                        varTransfer = True
                    Case "false"
                        varTransfer = False
                    Case "null"
                        varTransfer = Null
                End Select
        End Select
    End With
End Sub

Function BeautifyJson(varJson As Variant) As String
    Dim strResult As String
    Dim lngIndent As Long
    BeautifyJson = ""
    lngIndent = 0
    BeautyTraverse BeautifyJson, lngIndent, varJson, vbTab, 1
End Function

Sub BeautyTraverse(strResult As String, lngIndent As Long, varElement As Variant, strIndent As String, lngStep As Long)
    Dim arrKeys() As Variant
    Dim lngIndex As Long
    Dim strTemp As String

    Select Case VarType(varElement)
        Case vbObject
            If varElement.Count = 0 Then
                strResult = strResult & "{}"
            Else
                strResult = strResult & "{" & vbCrLf
                lngIndent = lngIndent + lngStep
                arrKeys = varElement.Keys
                For lngIndex = 0 To UBound(arrKeys)
                    strResult = strResult & String(lngIndent, strIndent) & """" & arrKeys(lngIndex) & """" & ": "
                    BeautyTraverse strResult, lngIndent, varElement(arrKeys(lngIndex)), strIndent, lngStep
                    If Not (lngIndex = UBound(arrKeys)) Then strResult = strResult & ","
                    strResult = strResult & vbCrLf
                Next
                lngIndent = lngIndent - lngStep
                strResult = strResult & String(lngIndent, strIndent) & "}"
            End If
        Case Is >= vbArray
            If UBound(varElement) = -1 Then
                strResult = strResult & "[]"
            Else
                strResult = strResult & "[" & vbCrLf
                lngIndent = lngIndent + lngStep
                For lngIndex = 0 To UBound(varElement)
                    strResult = strResult & String(lngIndent, strIndent)
                    BeautyTraverse strResult, lngIndent, varElement(lngIndex), strIndent, lngStep
                    If Not (lngIndex = UBound(varElement)) Then strResult = strResult & ","
                    strResult = strResult & vbCrLf
                Next
                lngIndent = lngIndent - lngStep
                strResult = strResult & String(lngIndent, strIndent) & "]"
            End If
        Case vbInteger, vbLong, vbSingle, vbDouble
            strResult = strResult & varElement
        Case vbNull
            strResult = strResult & "Null"
        Case vbBoolean
            strResult = strResult & IIf(varElement, "True", "False")
        Case Else
            strTemp = Replace(varElement, "\""", """")
            strTemp = Replace(strTemp, "\", "\\")
            strTemp = Replace(strTemp, "/", "\/")
            strTemp = Replace(strTemp, Chr(8), "\b")
            strTemp = Replace(strTemp, Chr(12), "\f")
            strTemp = Replace(strTemp, vbLf, "\n")
            strTemp = Replace(strTemp, vbCr, "\r")
            strTemp = Replace(strTemp, vbTab, "\t")
            strResult = strResult & """" & strTemp & """"
    End Select

End Sub

Function ReadTextFile(strPath As String, lngFormat As Long) As String
    ' lngFormat -2 - System default, -1 - Unicode, 0 - ASCII
    With CreateObject("Scripting.FileSystemObject").OpenTextFile(strPath, 1, False, lngFormat)
        ReadTextFile = ""
        If Not .AtEndOfStream Then ReadTextFile = .ReadAll
        .Close
    End With
End Function

Sub WriteTextFile(strContent As String, strPath As String, lngFormat As Long)
    With CreateObject("Scripting.FileSystemObject").OpenTextFile(strPath, 2, True, lngFormat)
        .Write (strContent)
        .Close
    End With
End Sub

Eine weitere Möglichkeit dieses JSON RegEx-Parsers besteht darin, dass er in 64-Bit-Office funktioniert, in dem ScriptControl nicht verfügbar ist.

INITIAL (27. Mai 15)

Hier ist eine weitere Methode zum Parsen von JSON in VBA, basierend auf ScriptControlActiveX, ohne externe Bibliotheken:

Sub JsonTest()

    Dim Dict, Temp, Text, Keys, Items

    ' Converting JSON string to appropriate nested dictionaries structure
    ' Dictionaries have numeric keys for JSON Arrays, and string keys for JSON Objects
    ' Returns Nothing in case of any JSON syntax issues
    Set Dict = GetJsonDict("{a:[[{stuff:'result'}]], b:''}")
    ' You can use For Each ... Next and For ... Next loops through keys and items
    Keys = Dict.Keys
    Items = Dict.Items

    ' Referring directly to the necessary property if sure, without any checks
    MsgBox Dict("a")(0)(0)("stuff")

    ' Auxiliary DrillDown() function
    ' Drilling down the structure, sequentially checking if each level exists
    Select Case False
    Case DrillDown(Dict, "a", Temp, "")
    Case DrillDown(Temp, 0, Temp, "")
    Case DrillDown(Temp, 0, Temp, "")
    Case DrillDown(Temp, "stuff", "", Text)
    Case Else
        ' Structure is consistent, requested value found
        MsgBox Text
    End Select

End Sub

Function GetJsonDict(JsonString As String)
    With CreateObject("ScriptControl")
        .Language = "JScript"
        .ExecuteStatement "function gettype(sample) {return {}.toString.call(sample).slice(8, -1)}"
        .ExecuteStatement "function evaljson(json, er) {try {var sample = eval('(' + json + ')'); var type = gettype(sample); if(type != 'Array' && type != 'Object') {return er;} else {return getdict(sample);}} catch(e) {return er;}}"
        .ExecuteStatement "function getdict(sample) {var type = gettype(sample); if(type != 'Array' && type != 'Object') return sample; var dict = new ActiveXObject('Scripting.Dictionary'); if(type == 'Array') {for(var key = 0; key < sample.length; key++) {dict.add(key, getdict(sample[key]));}} else {for(var key in sample) {dict.add(key, getdict(sample[key]));}} return dict;}"
        Set GetJsonDict = .Run("evaljson", JsonString, Nothing)
    End With
End Function

Function DrillDown(Source, Prop, Target, Value)
    Select Case False
    Case TypeName(Source) = "Dictionary"
    Case Source.exists(Prop)
    Case Else
        Select Case True
        Case TypeName(Source(Prop)) = "Dictionary"
            Set Target = Source(Prop)
            Value = Empty
        Case IsObject(Source(Prop))
            Set Value = Source(Prop)
            Set Target = Nothing
        Case Else
            Value = Source(Prop)
            Set Target = Nothing
        End Select
        DrillDown = True
        Exit Function
    End Select
    DrillDown = False
End Function

Da Json nichts anderes als Strings ist, kann es leicht gehandhabt werden, wenn wir es richtig manipulieren können, egal wie komplex die Struktur ist. Ich denke nicht, dass es notwendig ist, eine externe Bibliothek oder einen Konverter zu verwenden, um den Trick auszuführen. Hier ist ein Beispiel, in dem ich JSON-Daten mithilfe der Zeichenfolgenmanipulation analysiert habe.

Sub FetchData()
    Dim str As Variant, N&, R&

    With New XMLHTTP60
        .Open "GET", "https://oresapp.asicanada.net/ores.imis.services/api/member/?address=&callback=angular.callbacks._0&city=&companyName=&personName=", False
        .send
        str = Split(.responseText, ":[{""Id"":")
    End With

    N = UBound(str)

    For R = 1 To N
        Cells(R, 1) = Split(Split(str(R), "FullName"":""")(1), """")(0)
        Cells(R, 2) = Split(Split(str(R), "Phone"":""")(1), """")(0)
        Cells(R, 3) = Split(Split(str(R), "Email"":""")(1), """")(0)
    Next R
End Sub

Einfacher geht es mit array.myitem (0) im VB-Code

meine vollständige Antwort hier analysieren und stringifizieren (serialisieren)

Verwenden Sie das 'this'-Objekt in js

ScriptEngine.AddCode "Object.prototype.myitem=function( i ) { return this[i] } ; "

Dann können Sie array.myitem (0) gehen

Private ScriptEngine As ScriptControl

Public Sub InitScriptEngine()
    Set ScriptEngine = New ScriptControl
    ScriptEngine.Language = "JScript"
    ScriptEngine.AddCode "Object.prototype.myitem=function( i ) { return this[i] } ; "
    Set foo = ScriptEngine.Eval("(" + "[ 1234, 2345 ]" + ")") ' JSON array
    Debug.Print foo.myitem(1) ' method case sensitive!
    Set foo = ScriptEngine.Eval("(" + "{ ""key1"":23 , ""key2"":2345 }" + ")") ' JSON key value
    Debug.Print foo.myitem("key1") ' WTF

End Sub

Um JSON in VBA zu analysieren, ohne Ihrem Arbeitsmappenprojekt eine große Bibliothek hinzuzufügen, habe ich die folgende Lösung erstellt. Es ist extrem schnell und speichert alle Schlüssel und Werte in einem Wörterbuch für den einfachen Zugriff:

Function ParseJSON(json$, Optional key$ = "obj") As Object
    p = 1
    token = Tokenize(json)
    Set dic = CreateObject("Scripting.Dictionary")
    If token(p) = "{" Then ParseObj key Else ParseArr key
    Set ParseJSON = dic
End Function

Function ParseObj(key$)
    Do: p = p + 1
        Select Case token(p)
            Case "]"
            Case "[":  ParseArr key
            Case "{"
                       If token(p + 1) = "}" Then
                           p = p + 1
                           dic.Add key, "null"
                       Else
                           ParseObj key
                       End If
            
            Case "}":  key = ReducePath(key): Exit Do
            Case ":":  key = key & "." & token(p - 1)
            Case ",":  key = ReducePath(key)
            Case Else: If token(p + 1) <> ":" Then dic.Add key, token(p)
        End Select
    Loop
End Function

Function ParseArr(key$)
    Dim e&
    Do: p = p + 1
        Select Case token(p)
            Case "}"
            Case "{":  ParseObj key & ArrayID(e)
            Case "[":  ParseArr key
            Case "]":  Exit Do
            Case ":":  key = key & ArrayID(e)
            Case ",":  e = e + 1
            Case Else: dic.Add key & ArrayID(e), token(p)
        End Select
    Loop
End Function

Der obige Code verwendet einige Hilfsfunktionen, aber der obige ist das Fleisch davon.

Die hier verwendete Strategie besteht darin, einen rekursiven Tokenizer zu verwenden. Ich fand es interessant genug, einen Artikel über diese Lösung auf Medium zu schreiben . Es erklärt die Details.

Hier ist die vollständige (und dennoch überraschend kurze) Codeliste, einschließlich aller Hilfsfunktionen:

'-------------------------------------------------------------------
' VBA JSON Parser
'-------------------------------------------------------------------
Option Explicit
Private p&, token, dic
Function ParseJSON(json$, Optional key$ = "obj") As Object
    p = 1
    token = Tokenize(json)
    Set dic = CreateObject("Scripting.Dictionary")
    If token(p) = "{" Then ParseObj key Else ParseArr key
    Set ParseJSON = dic
End Function
Function ParseObj(key$)
    Do: p = p + 1
        Select Case token(p)
            Case "]"
            Case "[":  ParseArr key
            Case "{"
                       If token(p + 1) = "}" Then
                           p = p + 1
                           dic.Add key, "null"
                       Else
                           ParseObj key
                       End If
            
            Case "}":  key = ReducePath(key): Exit Do
            Case ":":  key = key & "." & token(p - 1)
            Case ",":  key = ReducePath(key)
            Case Else: If token(p + 1) <> ":" Then dic.Add key, token(p)
        End Select
    Loop
End Function
Function ParseArr(key$)
    Dim e&
    Do: p = p + 1
        Select Case token(p)
            Case "}"
            Case "{":  ParseObj key & ArrayID(e)
            Case "[":  ParseArr key
            Case "]":  Exit Do
            Case ":":  key = key & ArrayID(e)
            Case ",":  e = e + 1
            Case Else: dic.Add key & ArrayID(e), token(p)
        End Select
    Loop
End Function
'-------------------------------------------------------------------
' Support Functions
'-------------------------------------------------------------------
Function Tokenize(s$)
    Const Pattern = """(([^""\\]|\\.)*)""|[+\-]?(?:0|[1-9]\d*)(?:\.\d*)?(?:[eE][+\-]?\d+)?|\w+|[^\s""']+?"
    Tokenize = RExtract(s, Pattern, True)
End Function
Function RExtract(s$, Pattern, Optional bGroup1Bias As Boolean, Optional bGlobal As Boolean = True)
  Dim c&, m, n, v
  With CreateObject("vbscript.regexp")
    .Global = bGlobal
    .MultiLine = False
    .IgnoreCase = True
    .Pattern = Pattern
    If .TEST(s) Then
      Set m = .Execute(s)
      ReDim v(1 To m.Count)
      For Each n In m
        c = c + 1
        v(c) = n.value
        If bGroup1Bias Then If Len(n.submatches(0)) Or n.value = """""" Then v(c) = n.submatches(0)
      Next
    End If
  End With
  RExtract = v
End Function
Function ArrayID$(e)
    ArrayID = "(" & e & ")"
End Function
Function ReducePath$(key$)
    If InStr(key, ".") Then ReducePath = Left(key, InStrRev(key, ".") - 1)
End Function
Function ListPaths(dic)
    Dim s$, v
    For Each v In dic
        s = s & v & " --> " & dic(v) & vbLf
    Next
    Debug.Print s
End Function
Function GetFilteredValues(dic, match)
    Dim c&, i&, v, w
    v = dic.keys
    ReDim w(1 To dic.Count)
    For i = 0 To UBound(v)
        If v(i) Like match Then
            c = c + 1
            w(c) = dic(v(i))
        End If
    Next
    ReDim Preserve w(1 To c)
    GetFilteredValues = w
End Function
Function GetFilteredTable(dic, cols)
    Dim c&, i&, j&, v, w, z
    v = dic.keys
    z = GetFilteredValues(dic, cols(0))
    ReDim w(1 To UBound(z), 1 To UBound(cols) + 1)
    For j = 1 To UBound(cols) + 1
         z = GetFilteredValues(dic, cols(j - 1))
         For i = 1 To UBound(z)
            w(i, j) = z(i)
         Next
    Next
    GetFilteredTable = w
End Function
Function OpenTextFile$(f)
    With CreateObject("ADODB.Stream")
        .Charset = "utf-8"
        .Open
        .LoadFromFile f
        OpenTextFile = .ReadText
    End With
End Function

Dies funktioniert für mich unter Excel und einer großen JSON-Datei mit JSON-Abfrage, die in native Form übersetzt wurde. https://github.com/VBA-tools/VBA-JSON Ich kann Knoten wie "item.something" analysieren und mit einem einfachen Befehl einen Wert erhalten:

MsgBox Json("item")("something")

Was ist schön

Vielen Dank Codo.

Ich habe gerade aktualisiert und abgeschlossen, was Sie getan haben:

• Serialisieren Sie den JSON (ich brauche ihn, um den JSON in ein textähnliches Dokument einzufügen)

• Knoten hinzufügen, entfernen und aktualisieren (wer weiß)

  Option Explicit
  
  Private ScriptEngine As ScriptControl
  
  Public Sub InitScriptEngine()
      Set ScriptEngine = New ScriptControl
      ScriptEngine.Language = "JScript"
      ScriptEngine.AddCode "function getProperty(jsonObj, propertyName) { return jsonObj[propertyName]; } "
      ScriptEngine.AddCode "function getType(jsonObj, propertyName) {return typeof(jsonObj[propertyName]);}"
      ScriptEngine.AddCode "function getKeys(jsonObj) { var keys = new Array(); for (var i in jsonObj) { keys.push(i); } return keys; } "
      ScriptEngine.AddCode "function addKey(jsonObj, propertyName, value) { jsonObj[propertyName] = value; return jsonObj;}"
      ScriptEngine.AddCode "function removeKey(jsonObj, propertyName) { var json = jsonObj; delete json[propertyName]; return json }"
  End Sub
  Public Function removeJSONProperty(ByVal JsonObject As Object, propertyName As String)
      Set removeJSONProperty = ScriptEngine.Run("removeKey", JsonObject, propertyName)
  End Function
  
  Public Function updateJSONPropertyValue(ByVal JsonObject As Object, propertyName As String, value As String) As Object
      Set updateJSONPropertyValue = ScriptEngine.Run("removeKey", JsonObject, propertyName)
      Set updateJSONPropertyValue = ScriptEngine.Run("addKey", JsonObject, propertyName, value)
  End Function
  
  
  
  Public Function addJSONPropertyValue(ByVal JsonObject As Object, propertyName As String, value As String) As Object
      Set addJSONPropertyValue = ScriptEngine.Run("addKey", JsonObject, propertyName, value)
  End Function
  Public Function DecodeJsonString(ByVal JsonString As String)
  InitScriptEngine
      Set DecodeJsonString = ScriptEngine.Eval("(" + JsonString + ")")
  End Function
  
  Public Function GetProperty(ByVal JsonObject As Object, ByVal propertyName As String) As Variant
      GetProperty = ScriptEngine.Run("getProperty", JsonObject, propertyName)
  End Function
  
  Public Function GetObjectProperty(ByVal JsonObject As Object, ByVal propertyName As String) As Object
      Set GetObjectProperty = ScriptEngine.Run("getProperty", JsonObject, propertyName)
  End Function
  
  Public Function SerializeJSONObject(ByVal JsonObject As Object) As String()
      Dim Length As Integer
      Dim KeysArray() As String
      Dim KeysObject As Object
      Dim Index As Integer
      Dim Key As Variant
      Dim tmpString As String
      Dim tmpJSON As Object
      Dim tmpJSONArray() As Variant
      Dim tmpJSONObject() As Variant
      Dim strJsonObject As String
      Dim tmpNbElement As Long, i As Long
      InitScriptEngine
      Set KeysObject = ScriptEngine.Run("getKeys", JsonObject)
  
      Length = GetProperty(KeysObject, "length")
      ReDim KeysArray(Length - 1)
      Index = 0
      For Each Key In KeysObject
      tmpString = ""
          If ScriptEngine.Run("getType", JsonObject, Key) = "object" Then
      'MsgBox "object " & SerializeJSONObject(GetObjectProperty(JsonObject, Key))(0)
              Set tmpJSON = GetObjectProperty(JsonObject, Key)
              strJsonObject = VBA.Replace(ScriptEngine.Run("getKeys", tmpJSON), " ", "")
              tmpNbElement = Len(strJsonObject) - Len(VBA.Replace(strJsonObject, ",", ""))
  
              If VBA.IsNumeric(Left(ScriptEngine.Run("getKeys", tmpJSON), 1)) = True Then
  
                  ReDim tmpJSONArray(tmpNbElement)
                  For i = 0 To tmpNbElement
                      tmpJSONArray(i) = GetProperty(tmpJSON, i)
                  Next
                      tmpString = "[" & Join(tmpJSONArray, ",") & "]"
              Else
                  tmpString = "{" & Join(SerializeJSONObject(tmpJSON), ", ") & "}"
              End If
  
          Else
                  tmpString = GetProperty(JsonObject, Key)
  
          End If
  
          KeysArray(Index) = Key & ": " & tmpString
          Index = Index + 1
      Next
  
      SerializeJSONObject = KeysArray
  
  End Function
  
  Public Function GetKeys(ByVal JsonObject As Object) As String()
      Dim Length As Integer
      Dim KeysArray() As String
      Dim KeysObject As Object
      Dim Index As Integer
      Dim Key As Variant
  InitScriptEngine
      Set KeysObject = ScriptEngine.Run("getKeys", JsonObject)
      Length = GetProperty(KeysObject, "length")
      ReDim KeysArray(Length - 1)
      Index = 0
      For Each Key In KeysObject
          KeysArray(Index) = Key
          Index = Index + 1
      Next
      GetKeys = KeysArray
  End Function
  

Microsoft : Da VBScript eine Teilmenge von Visual Basic für Applikationen ist, ...

Der folgende Code stammt aus Codos Beitrag, sollte er auch in Klassenform hilfreich sein und als VBScript verwendet werden können :

class JsonParser
    ' adapted from: http://stackoverflow.com/questions/6627652/parsing-json-in-excel-vba
    private se
    private sub Class_Initialize
        set se = CreateObject("MSScriptControl.ScriptControl") 
        se.Language = "JScript"
        se.AddCode "function getValue(jsonObj, valueName) { return jsonObj[valueName]; } "
        se.AddCode "function enumKeys(jsonObj) { var keys = new Array(); for (var i in jsonObj) { keys.push(i); } return keys; } "
    end sub
    public function Decode(ByVal json)
        set Decode = se.Eval("(" + cstr(json) + ")")
    end function

    public function GetValue(ByVal jsonObj, ByVal valueName)
        GetValue = se.Run("getValue", jsonObj, valueName)
    end function

    public function GetObject(ByVal jsonObject, ByVal valueName)
        set GetObjet = se.Run("getValue", jsonObject, valueName)
    end function

    public function EnumKeys(ByVal jsonObject)
        dim length, keys, obj, idx, key
        set obj = se.Run("enumKeys", jsonObject)
        length = GetValue(obj, "length")
        redim keys(length - 1)
        idx = 0
        for each key in obj
            keys(idx) = key
            idx = idx + 1
        next
        EnumKeys = keys
    end function
end class

Verwendung:

set jp = new JsonParser
set jo = jp.Decode("{value: true}")
keys = jp.EnumKeys(jo)
value = jp.GetValue(jo, "value")

Ein weiterer Regex-basierter JSON-Parser (nur dekodieren)

Private Enum JsonStep
    jsonString
    jsonNumber
    jsonTrue
    jsonFalse
    jsonNull
    jsonOpeningBrace
    jsonClosingBrace
    jsonOpeningBracket
    jsonClosingBracket
    jsonComma
    jsonColon
End Enum

Private regexp As Object

Private Function JsonStepName(ByVal json_step As JsonStep) As String
    Select Case json_step
        Case jsonString: JsonStepName = "'STRING'"
        Case jsonNumber: JsonStepName = "'NUMBER'"
        Case jsonTrue: JsonStepName = "true"
        Case jsonFalse: JsonStepName = "false"
        Case jsonNull: JsonStepName = "null"
        Case jsonOpeningBrace: JsonStepName = "'{'"
        Case jsonClosingBrace: JsonStepName = "'}'"
        Case jsonOpeningBracket: JsonStepName = "'['"
        Case jsonClosingBracket: JsonStepName = "']'"
        Case jsonComma: JsonStepName = "','"
        Case jsonColon: JsonStepName = "':'"
    End Select
End Function

Private Function Unescape(ByVal str As String) As String
    Dim match As Object

    str = Replace$(str, "\""", """")
    str = Replace$(str, "\\", "\")
    str = Replace$(str, "\/", "/")
    str = Replace$(str, "\b", vbBack)
    str = Replace$(str, "\f", vbFormFeed)
    str = Replace$(str, "\n", vbCrLf)
    str = Replace$(str, "\r", vbCr)
    str = Replace$(str, "\t", vbTab)
    With regexp
        .Global = True
        .IgnoreCase = False
        .MultiLine = False
        .Pattern = "\\u([0-9a-fA-F]{4})"
        For Each match In .Execute(str)
            str = Replace$(str, match.value, ChrW$(Val("&H" + match.SubMatches(0))), match.FirstIndex + 1, 1)
        Next match
    End With
    Unescape = str
End Function

Private Function ParseStep(ByVal str As String, _
                           ByRef index As Long, _
                           ByRef value As Variant, _
                           ByVal json_step As JsonStep, _
                           ByVal expected As Boolean) As Boolean
    Dim match As Object

    With regexp
        .Global = False
        .IgnoreCase = False
        .MultiLine = False
        Select Case json_step
            'Case jsonString: .Pattern = "^\s*""(([^\\""]+|\\[""\\/bfnrt]|\\u[0-9a-fA-F]{4})*)""\s*"
            Case jsonString: .Pattern = "^\s*""([^\\""]+|([^\\""]+|\\[""\\/bfnrt]|\\u[0-9a-fA-F]{4})*)""\s*"
            Case jsonNumber: .Pattern = "^\s*(-?(0|[1-9]\d*)(\.\d+)?([eE][-+]?\d+)?)\s*"
            Case jsonTrue: .Pattern = "^\s*(true)\s*"
            Case jsonFalse: .Pattern = "^\s*(false)\s*"
            Case jsonNull: .Pattern = "^\s*(null)\s*"
            Case jsonOpeningBrace: .Pattern = "^\s*(\{)\s*"
            Case jsonClosingBrace: .Pattern = "^\s*(\})\s*"
            Case jsonOpeningBracket: .Pattern = "^\s*(\[)\s*"
            Case jsonClosingBracket: .Pattern = "^\s*(\])\s*"
            Case jsonComma: .Pattern = "^\s*(\,)\s*"
            Case jsonColon: .Pattern = "^\s*(:)\s*"
        End Select
        Set match = .Execute(Mid$(str, index))
    End With
    If match.Count > 0 Then
        index = index + match(0).Length
        Select Case json_step
            Case jsonString
                If match(0).SubMatches(1) = Empty Then
                    value = match(0).SubMatches(0)
                Else
                    value = Unescape(match(0).SubMatches(0))
                End If
            Case jsonNumber: value = Val(match(0).SubMatches(0))
            Case jsonTrue: value = True
            Case jsonFalse: value = False
            Case jsonNull: value = Null
            Case Else: value = Empty
        End Select
        ParseStep = True
    ElseIf expected Then
        Err.Raise 10001, "ParseJson", "Expecting " & JsonStepName(json_step) & " at char " & index & "."
    End If
End Function

Private Function ParseValue(ByRef str As String, _
                            ByRef index As Long, _
                            ByRef value As Variant, _
                            ByVal expected As Boolean) As Boolean
    ParseValue = True
    If ParseStep(str, index, value, jsonString, False) Then Exit Function
    If ParseStep(str, index, value, jsonNumber, False) Then Exit Function
    If ParseObject(str, index, value, False) Then Exit Function
    If ParseArray(str, index, value, False) Then Exit Function
    If ParseStep(str, index, value, jsonTrue, False) Then Exit Function
    If ParseStep(str, index, value, jsonFalse, False) Then Exit Function
    If ParseStep(str, index, value, jsonNull, False) Then Exit Function
    ParseValue = False
    If expected Then
        Err.Raise 10001, "ParseJson", "Expecting " & JsonStepName(jsonString) & ", " & JsonStepName(jsonNumber) & ", " & JsonStepName(jsonTrue) & ", " & JsonStepName(jsonFalse) & ", " & JsonStepName(jsonNull) & ", " & JsonStepName(jsonOpeningBrace) & ", or " & JsonStepName(jsonOpeningBracket) & " at char " & index & "."
    End If
End Function

Private Function ParseObject(ByRef str As String, _
                             ByRef index As Long, _
                             ByRef obj As Variant, _
                             ByVal expected As Boolean) As Boolean
    Dim key As Variant
    Dim value As Variant

    ParseObject = ParseStep(str, index, Empty, jsonOpeningBrace, expected)
    If ParseObject Then
        Set obj = CreateObject("Scripting.Dictionary")
        If ParseStep(str, index, Empty, jsonClosingBrace, False) Then Exit Function
        Do
            If ParseStep(str, index, key, jsonString, True) Then
                If ParseStep(str, index, Empty, jsonColon, True) Then
                    If ParseValue(str, index, value, True) Then
                        If IsObject(value) Then
                            Set obj.Item(key) = value
                        Else
                            obj.Item(key) = value
                        End If
                    End If
                End If
            End If
        Loop While ParseStep(str, index, Empty, jsonComma, False)
        ParseObject = ParseStep(str, index, Empty, jsonClosingBrace, True)
    End If
End Function

Private Function ParseArray(ByRef str As String, _
                            ByRef index As Long, _
                            ByRef arr As Variant, _
                            ByVal expected As Boolean) As Boolean
    Dim key As Variant
    Dim value As Variant

    ParseArray = ParseStep(str, index, Empty, jsonOpeningBracket, expected)
    If ParseArray Then
        Set arr = New Collection
        If ParseStep(str, index, Empty, jsonClosingBracket, False) Then Exit Function
        Do
            If ParseValue(str, index, value, True) Then
                arr.Add value
            End If
        Loop While ParseStep(str, index, Empty, jsonComma, False)
        ParseArray = ParseStep(str, index, Empty, jsonClosingBracket, True)
    End If
End Function

Public Function ParseJson(ByVal str As String) As Object
    If regexp Is Nothing Then
        Set regexp = CreateObject("VBScript.RegExp")
    End If
    If ParseObject(str, 1, ParseJson, False) Then Exit Function
    If ParseArray(str, 1, ParseJson, False) Then Exit Function
    Err.Raise 10001, "ParseJson", "Expecting " & JsonStepName(jsonOpeningBrace) & " or " & JsonStepName(jsonOpeningBracket) & "."
End Function

Zwei kleine Beiträge zu Codos Antwort:

' "recursive" version of GetObjectProperty
Public Function GetObjectProperty(ByVal JsonObject As Object, ByVal propertyName As String) As Object
    Dim names() As String
    Dim i As Integer

    names = Split(propertyName, ".")

    For i = 0 To UBound(names)
        Set JsonObject = ScriptEngine.Run("getProperty", JsonObject, names(i))
    Next

    Set GetObjectProperty = JsonObject
End Function

' shortcut to object array
Public Function GetObjectArrayProperty(ByVal JsonObject As Object, ByVal propertyName As String) As Object()
    Dim a() As Object
    Dim i As Integer
    Dim l As Integer

    Set JsonObject = GetObjectProperty(JsonObject, propertyName)

    l = GetProperty(JsonObject, "length") - 1

    ReDim a(l)

    For i = 0 To l
        Set a(i) = GetObjectProperty(JsonObject, CStr(i))
    Next

    GetObjectArrayProperty = a
End Function

Jetzt kann ich also Dinge tun wie:

Dim JsonObject As Object
Dim Value() As Object
Dim i As Integer
Dim Total As Double

Set JsonObject = DecodeJsonString(CStr(request.responseText))

Value = GetObjectArrayProperty(JsonObject, "d.Data")

For i = 0 To UBound(Value)
    Total = Total + Value(i).Amount
Next

Viele gute Antworten hier - nur meine eigenen.

Ich musste eine sehr spezifische JSON-Zeichenfolge analysieren, die die Ergebnisse eines Web-API-Aufrufs darstellt. Der JSON beschrieb eine Liste von Objekten und sah ungefähr so ​​aus:

[
   {
     "property1": "foo",
     "property2": "bar",
     "timeOfDay": "2019-09-30T00:00:00",
     "numberOfHits": 98,
     "isSpecial": false,
     "comment": "just to be awkward, this contains a comma"
   },
   {
     "property1": "fool",
     "property2": "barrel",
     "timeOfDay": "2019-10-31T00:00:00",
     "numberOfHits": 11,
     "isSpecial": false,
     "comment": null
   },
   ...
]

Hierzu sind einige Dinge zu beachten:

1. Der JSON sollte immer eine Liste beschreiben (auch wenn diese leer ist), die nur Objekte enthalten sollte.
2. Die Objekte in der Liste sollten nur Eigenschaften mit einfachen Typen enthalten (Zeichenfolge / Datum / Nummer / Boolescher Wert oder null).
3. Der Wert einer Immobilie kann ein Komma enthalten - , die die JSON etwas schwieriger macht Parsen - aber möglicherweise nicht alle Zitate enthält (weil ich zu faul bin , das zu lösen ist ).

Die ParseListOfObjectsFunktion im folgenden Code verwendet die JSON-Zeichenfolge als Eingabe und gibt eine CollectionDarstellung der Elemente in der Liste zurück. Jedes Element wird als a dargestellt Dictionary, wobei die Schlüssel des Wörterbuchs den Namen der Objekteigenschaften entsprechen. Die Werte werden automatisch in den entsprechenden Typ umgewandelt ( String, Date, Double, Boolean- oder , Emptywenn der Wert ist null).

Ihr VBA-Projekt benötigt einen Verweis auf die Microsoft Scripting RuntimeBibliothek, um das DictionaryObjekt verwenden zu können. Es ist jedoch nicht schwierig, diese Abhängigkeit zu entfernen, wenn Sie die Ergebnisse auf andere Weise codieren.

Hier ist mein JSON.bas:

Option Explicit

' NOTE: a fully-featured JSON parser in VBA would be a beast.
' This simple parser only supports VERY simple JSON (which is all we need).
' Specifically, it supports JSON comprising a list of objects, each of which has only simple properties.

Private Const strSTART_OF_LIST As String = "["
Private Const strEND_OF_LIST As String = "]"

Private Const strLIST_DELIMITER As String = ","

Private Const strSTART_OF_OBJECT As String = "{"
Private Const strEND_OF_OBJECT As String = "}"

Private Const strOBJECT_PROPERTY_NAME_VALUE_SEPARATOR As String = ":"

Private Const strQUOTE As String = """"

Private Const strNULL_VALUE As String = "null"
Private Const strTRUE_VALUE As String = "true"
Private Const strFALSE_VALUE As String = "false"


Public Function ParseListOfObjects(ByVal strJson As String) As Collection

    ' Takes a JSON string that represents a list of objects (where each object has only simple value properties), and
    ' returns a collection of dictionary objects, where the keys and values of each dictionary represent the names and
    ' values of the JSON object properties.

    Set ParseListOfObjects = New Collection

    Dim strList As String: strList = Trim(strJson)

    ' Check we have a list
    If Left(strList, Len(strSTART_OF_LIST)) <> strSTART_OF_LIST _
    Or Right(strList, Len(strEND_OF_LIST)) <> strEND_OF_LIST Then
        Err.Raise vbObjectError, Description:="The provided JSON does not appear to be a list (it does not start with '" & strSTART_OF_LIST & "' and end with '" & strEND_OF_LIST & "')"
    End If

    ' Get the list item text (between the [ and ])
    Dim strBody As String: strBody = Trim(Mid(strList, 1 + Len(strSTART_OF_LIST), Len(strList) - Len(strSTART_OF_LIST) - Len(strEND_OF_LIST)))

    If strBody = "" Then
        Exit Function
    End If

    ' Check we have a list of objects
    If Left(strBody, Len(strSTART_OF_OBJECT)) <> strSTART_OF_OBJECT Then
        Err.Raise vbObjectError, Description:="The provided JSON does not appear to be a list of objects (the content of the list does not start with '" & strSTART_OF_OBJECT & "')"
    End If

    ' We now have something like:
    '    {"property":"value", "property":"value"}, {"property":"value", "property":"value"}, ...
    ' so we can't just split on a comma to get the various items (because the items themselves have commas in them).
    ' HOWEVER, since we know we're dealing with very simple JSON that has no nested objects, we can split on "}," because
    ' that should only appear between items. That'll mean that all but the last item will be missing it's closing brace.
    Dim astrItems() As String: astrItems = Split(strBody, strEND_OF_OBJECT & strLIST_DELIMITER)

    Dim ixItem As Long
    For ixItem = LBound(astrItems) To UBound(astrItems)

        Dim strItem As String: strItem = Trim(astrItems(ixItem))

        If Left(strItem, Len(strSTART_OF_OBJECT)) <> strSTART_OF_OBJECT Then
            Err.Raise vbObjectError, Description:="Mal-formed list item (does not start with '" & strSTART_OF_OBJECT & "')"
        End If

        ' Only the last item will have a closing brace (see comment above)
        Dim bIsLastItem As Boolean: bIsLastItem = ixItem = UBound(astrItems)

        If bIsLastItem Then
            If Right(strItem, Len(strEND_OF_OBJECT)) <> strEND_OF_OBJECT Then
                Err.Raise vbObjectError, Description:="Mal-formed list item (does not end with '" & strEND_OF_OBJECT & "')"
            End If
        End If

        Dim strContent: strContent = Mid(strItem, 1 + Len(strSTART_OF_OBJECT), Len(strItem) - Len(strSTART_OF_OBJECT) - IIf(bIsLastItem, Len(strEND_OF_OBJECT), 0))

        ParseListOfObjects.Add ParseObjectContent(strContent)

    Next ixItem

End Function

Private Function ParseObjectContent(ByVal strContent As String) As Scripting.Dictionary

    Set ParseObjectContent = New Scripting.Dictionary
    ParseObjectContent.CompareMode = TextCompare

    ' The object content will look something like:
    '    "property":"value", "property":"value", ...
    ' ... although the value may not be in quotes, since numbers are not quoted.
    ' We can't assume that the property value won't contain a comma, so we can't just split the
    ' string on the commas, but it's reasonably safe to assume that the value won't contain further quotes
    ' (and we're already assuming no sub-structure).
    ' We'll need to scan for commas while taking quoted strings into account.

    Dim ixPos As Long: ixPos = 1
    Do While ixPos <= Len(strContent)

        Dim strRemainder As String

        ' Find the opening quote for the name (names should always be quoted)
        Dim ixOpeningQuote As Long: ixOpeningQuote = InStr(ixPos, strContent, strQUOTE)

        If ixOpeningQuote <= 0 Then
            ' The only valid reason for not finding a quote is if we're at the end (though white space is permitted)
            strRemainder = Trim(Mid(strContent, ixPos))
            If Len(strRemainder) = 0 Then
                Exit Do
            End If
            Err.Raise vbObjectError, Description:="Mal-formed object (the object name does not start with a quote)"
        End If

        ' Now find the closing quote for the name, which we assume is the very next quote
        Dim ixClosingQuote As Long: ixClosingQuote = InStr(ixOpeningQuote + 1, strContent, strQUOTE)
        If ixClosingQuote <= 0 Then
            Err.Raise vbObjectError, Description:="Mal-formed object (the object name does not end with a quote)"
        End If

        If ixClosingQuote - ixOpeningQuote - Len(strQUOTE) = 0 Then
            Err.Raise vbObjectError, Description:="Mal-formed object (the object name is blank)"
        End If

        Dim strName: strName = Mid(strContent, ixOpeningQuote + Len(strQUOTE), ixClosingQuote - ixOpeningQuote - Len(strQUOTE))

        ' The next thing after the quote should be the colon

        Dim ixNameValueSeparator As Long: ixNameValueSeparator = InStr(ixClosingQuote + Len(strQUOTE), strContent, strOBJECT_PROPERTY_NAME_VALUE_SEPARATOR)

        If ixNameValueSeparator <= 0 Then
            Err.Raise vbObjectError, Description:="Mal-formed object (missing '" & strOBJECT_PROPERTY_NAME_VALUE_SEPARATOR & "')"
        End If

        ' Check that there was nothing between the closing quote and the colon

        strRemainder = Trim(Mid(strContent, ixClosingQuote + Len(strQUOTE), ixNameValueSeparator - ixClosingQuote - Len(strQUOTE)))
        If Len(strRemainder) > 0 Then
            Err.Raise vbObjectError, Description:="Mal-formed object (unexpected content between name and '" & strOBJECT_PROPERTY_NAME_VALUE_SEPARATOR & "')"
        End If

        ' What comes after the colon is the value, which may or may not be quoted (e.g. numbers are not quoted).
        ' If the very next thing we see is a quote, then it's a quoted value, and we need to find the matching
        ' closing quote while ignoring any commas inside the quoted value.
        ' If the next thing we see is NOT a quote, then it must be an unquoted value, and we can scan directly
        ' for the next comma.
        ' Either way, we're looking for a quote or a comma, whichever comes first (or neither, in which case we
        ' have the last - unquoted - value).

        ixOpeningQuote = InStr(ixNameValueSeparator + Len(strOBJECT_PROPERTY_NAME_VALUE_SEPARATOR), strContent, strQUOTE)
        Dim ixPropertySeparator As Long: ixPropertySeparator = InStr(ixNameValueSeparator + Len(strOBJECT_PROPERTY_NAME_VALUE_SEPARATOR), strContent, strLIST_DELIMITER)

        If ixOpeningQuote > 0 And ixPropertySeparator > 0 Then
            ' Only use whichever came first
            If ixOpeningQuote < ixPropertySeparator Then
                ixPropertySeparator = 0
            Else
                ixOpeningQuote = 0
            End If
        End If

        Dim strValue As String
        Dim vValue As Variant

        If ixOpeningQuote <= 0 Then ' it's not a quoted value

            If ixPropertySeparator <= 0 Then ' there's no next value; this is the last one
                strValue = Trim(Mid(strContent, ixNameValueSeparator + Len(strOBJECT_PROPERTY_NAME_VALUE_SEPARATOR)))
                ixPos = Len(strContent) + 1
            Else ' this is not the last value
                strValue = Trim(Mid(strContent, ixNameValueSeparator + Len(strOBJECT_PROPERTY_NAME_VALUE_SEPARATOR), ixPropertySeparator - ixNameValueSeparator - Len(strOBJECT_PROPERTY_NAME_VALUE_SEPARATOR)))
                ixPos = ixPropertySeparator + Len(strLIST_DELIMITER)
            End If

            vValue = ParseUnquotedValue(strValue)

        Else ' It is a quoted value

            ' Find the corresponding closing quote, which should be the very next one

            ixClosingQuote = InStr(ixOpeningQuote + Len(strQUOTE), strContent, strQUOTE)

            If ixClosingQuote <= 0 Then
                Err.Raise vbObjectError, Description:="Mal-formed object (the value does not end with a quote)"
            End If

            strValue = Mid(strContent, ixOpeningQuote + Len(strQUOTE), ixClosingQuote - ixOpeningQuote - Len(strQUOTE))
            vValue = ParseQuotedValue(strValue)

            ' Re-scan for the property separator, in case we hit one that was part of the quoted value
            ixPropertySeparator = InStr(ixClosingQuote + Len(strQUOTE), strContent, strLIST_DELIMITER)

            If ixPropertySeparator <= 0 Then ' this was the last value

                ' Check that there's nothing between the closing quote and the end of the text
                strRemainder = Trim(Mid(strContent, ixClosingQuote + Len(strQUOTE)))
                If Len(strRemainder) > 0 Then
                    Err.Raise vbObjectError, Description:="Mal-formed object (there is content after the last value)"
                End If

                ixPos = Len(strContent) + 1

            Else ' this is not the last value

                ' Check that there's nothing between the closing quote and the property separator
                strRemainder = Trim(Mid(strContent, ixClosingQuote + Len(strQUOTE), ixPropertySeparator - ixClosingQuote - Len(strQUOTE)))
                If Len(strRemainder) > 0 Then
                    Err.Raise vbObjectError, Description:="Mal-formed object (there is content after the last value)"
                End If

                ixPos = ixPropertySeparator + Len(strLIST_DELIMITER)

            End If

        End If

        ParseObjectContent.Add strName, vValue

    Loop

End Function

Private Function ParseUnquotedValue(ByVal strValue As String) As Variant

    If StrComp(strValue, strNULL_VALUE, vbTextCompare) = 0 Then
        ParseUnquotedValue = Empty
    ElseIf StrComp(strValue, strTRUE_VALUE, vbTextCompare) = 0 Then
        ParseUnquotedValue = True
    ElseIf StrComp(strValue, strFALSE_VALUE, vbTextCompare) = 0 Then
        ParseUnquotedValue = False
    ElseIf IsNumeric(strValue) Then
        ParseUnquotedValue = CDbl(strValue)
    Else
        Err.Raise vbObjectError, Description:="Mal-formed value (not null, true, false or a number)"
    End If

End Function

Private Function ParseQuotedValue(ByVal strValue As String) As Variant

    ' Both dates and strings are quoted; we'll treat it as a date if it has the expected date format.
    ' Dates are in the form:
    '    2019-09-30T00:00:00
    If strValue Like "####-##-##T##:00:00" Then
        ' NOTE: we just want the date part
        ParseQuotedValue = CDate(Left(strValue, Len("####-##-##")))
    Else
        ParseQuotedValue = strValue
    End If

End Function

Ein einfacher Test:

Const strJSON As String = "[{""property1"":""foo""}]"
Dim oObjects As Collection: Set oObjects = Json.ParseListOfObjects(strJSON)

MsgBox oObjects(1)("property1") ' shows "foo"