在 Excel VBA 中解析 JSON

Question

提问by Bastan

I have the same issue as in Excel VBA: Parsed JSON Object Loopbut cannot find any solution. My JSON has nested objects so suggested solution like VBJSON and vba-json do not work for me. I also fixed one of them to work properly but the result was a call stack overflow because of to many recursion of the doProcess function.

我有与Excel VBA相同的问题：解析 JSON 对象循环，但找不到任何解决方案。我的 JSON 具有嵌套对象，因此建议的解决方案（如 VBJSON 和 vba-json）对我不起作用。我还修复了其中一个以正常工作，但结果是由于 doProcess 函数的多次递归而导致调用堆栈溢出。

The best solution appears to be the jsonDecode function seen in the original post. It is very fast and highly effectively effective; my object structure is all there in a generic VBA Object of type JScriptTypeInfo.

最好的解决方案似乎是原始帖子中看到的 jsonDecode 函数。它非常快速且高效；我的对象结构都在一个 JScriptTypeInfo 类型的通用 VBA 对象中。

The issue at this point is that I cannot determine what will be the structure of the objects, therefore, I do not know beforehand the keys that will reside in each generic objects. I need to loop through the generic VBA Object to acquire the keys/properties.

此时的问题是我无法确定对象的结构是什么，因此，我事先不知道将驻留在每个通用对象中的键。我需要遍历通用 VBA 对象来获取键/属性。

If my parsing javascript function could trigger a VBA function or sub, that would be excellent.

如果我的解析 javascript 函数可以触发 VBA 函数或子函数，那就太好了。

Answer 1

采纳答案by Codo

If you want to build on top of ScriptControl, you can add a few helper method to get at the required information. The JScriptTypeInfoobject is a bit unfortunate: it contains all the relevant information (as you can see in the Watchwindow) but it seems impossible to get at it with VBA. However, the Javascript engine can help us:

如果你想建立在之上ScriptControl，你可以添加一些辅助方法来获取所需的信息。该JScriptTypeInfo对象有点不幸：它包含所有相关信息（如您在Watch窗口中所见），但似乎无法使用 VBA 获得它。但是，Javascript 引擎可以帮助我们：

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

A few notes:

一些注意事项：

If the JScriptTypeInfoinstance refers to a Javascript object, For Each ... Nextwon't work. However, it does work if it refers to a Javascript array (see GetKeysfunction).
The access properties whose name is only known at run-time, use the functions GetPropertyand GetObjectProperty.
The Javascript array provides the properties length, 0, Item 0, 1, Item 1etc. With the VBA dot notation (jsonObject.property), only the length property is accessible and only if you declare a variable called lengthwith all lowercase letters. Otherwise the case doesn't match and it won't find it. The other properties are not valid in VBA. So better use the GetPropertyfunction.
The code uses early binding. So you have to add a reference to "Microsoft Script Control 1.0".
You have to call InitScriptEngineonce before using the other functions to do some basic initialization.

如果JScriptTypeInfo实例引用 Javascript 对象，For Each ... Next则不起作用。但是，如果它引用 Javascript 数组，它确实可以工作（请参阅GetKeys函数）。
名称仅在运行时已知的访问属性使用函数GetProperty和GetObjectProperty。
JavaScript的阵列提供性能length，0，Item 0，1，Item 1等有了VBA点符号（jsonObject.property），只有length属性访问，则只有声明一个变量叫length所有的小写字母。否则案例不匹配，它不会找到它。其他属性在 VBA 中无效。所以最好使用该GetProperty功能。
该代码使用早期绑定。所以你必须添加对“Microsoft Script Control 1.0”的引用。
InitScriptEngine在使用其他函数进行一些基本初始化之前，您必须调用一次。

Answer 2

回答by omegastripes

UPDATE 3(Sep 24 '17)

更新 3（2017 年 9 月 24 日）

Check VBA-JSON-parser on GitHubfor the latest version and examples. Import JSON.basmodule into the VBA project for JSON processing.

查看GitHub 上的 VBA-JSON-parser 以获取最新版本和示例。将JSON.bas模块导入到 VBA 项目中进行 JSON 处理。

UPDATE 2(Oct 1 '16)

更新 2（2016 年 10 月 1 日）

However if you do want to parse JSON on 64-bit Office with ScriptControl, then this answermay help you to get ScriptControlto work on 64-bit.

但是，如果您确实想使用解析 64 位 Office 上的 JSON ScriptControl，那么此答案可能会帮助您开始ScriptControl在 64 位上工作。

UPDATE(Oct 26 '15)

更新（2015 年 10 月 26 日）

Note that a ScriptControl-based approachs makes the system vulnerable in some cases, since they allows a direct access to the drives (and other stuff) for the malicious JS code via ActiveX's. Let's suppose you are parsing web server response JSON, like JsonString = "{a:(function(){(new ActiveXObject('Scripting.FileSystemObject')).CreateTextFile('C:\\Test.txt')})()}". After evaluating it you'll find new created file C:\Test.txt. So JSON parsing with ScriptControlActiveX is not a good idea.

请注意，ScriptControl基于a的方法在某些情况下会使系统容易受到攻击，因为它们允许恶意 JS 代码通过 ActiveX 直接访问驱动器（和其他内容）。假设您正在解析 Web 服务器响应 JSON，例如JsonString = "{a:(function(){(new ActiveXObject('Scripting.FileSystemObject')).CreateTextFile('C:\\Test.txt')})()}". 评估后你会发现新创建的文件C:\Test.txt。所以用ScriptControlActiveX解析 JSON不是一个好主意。

Trying to avoid that, I've created JSON parser based on RegEx's. Objects {}are represented by dictionaries, that makes possible to use dictionary's properties and methods: .Count, .Exists(), .Item(), .Items, .Keys. Arrays []are the conventional zero-based VB arrays, so UBound()shows the number of elements. Here is the code with some usage examples:

为了避免这种情况，我创建了基于 RegEx 的 JSON 解析器。对象{}由字典表示，这使得使用字典的属性和方法成为可能：.Count, .Exists(), .Item(), .Items, .Keys。数组[]是传统的从零开始的 VB 数组，因此UBound()显示元素的数量。这是带有一些用法示例的代码：

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

One more opportunity of this JSON RegEx parser is that it works on 64-bit Office, where ScriptControl isn't available.

此 JSON RegEx 解析器的另一个机会是它适用于 64 位 Office，其中 ScriptControl 不可用。

INITIAL(May 27 '15)

初始（2015 年5 月 27 日）

Here is one more method to parse JSON in VBA, based on ScriptControlActiveX, without external libraries:

这是在 VBA 中解析 JSON 的另一种方法，基于ScriptControlActiveX，无需外部库：

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

Answer 3

回答by SIM

As Json is nothing but strings so it can easily be handled if we can manipulate it the right way, no matter how complex the structure is. I don't think it is necessary to use any external library or converter to do the trick. Here is an example where I've parsed json data using string manipulation.

因为 Json 只不过是字符串，所以如果我们能以正确的方式操作它，无论结构多么复杂，它都可以很容易地处理。我认为没有必要使用任何外部库或转换器来实现这一目标。这是我使用字符串操作解析 json 数据的示例。

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

Answer 4

回答by ozmike

Simpler way you can go array.myitem(0) in VB code

您可以在 VB 代码中使用 array.myitem(0) 的更简单方法

my full answer here parse and stringify (serialize)

我在这里的完整答案解析和字符串化（序列化）

Use the 'this' object in js

在js中使用'this'对象

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

Then you can go array.myitem(0)

然后你可以去 array.myitem(0)

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

Answer 5

回答by Viktor Procházka

This works for me under Excel and a big JSON files using JSON query translated in to native form. https://github.com/VBA-tools/VBA-JSONI am able parse node like "item.something" and get value using simple command:

这适用于我在 Excel 和使用 JSON 查询转换为本机形式的大型 JSON 文件。 https://github.com/VBA-tools/VBA-JSON我能够解析像“item.something”这样的节点并使用简单的命令获取值：

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

What's nice.

有什么好看的。

Answer 6

回答by Gary McGill

Lots of good answers here - just chipping in my own.

这里有很多很好的答案 - 只是我自己的。

I had a requirement to parse a very specific JSON string, representing the results of making a web-API call. The JSON described a list of objects, and looked something like this:

我需要解析一个非常具体的 JSON 字符串，表示进行 Web-API 调用的结果。JSON 描述了一个对象列表，看起来像这样：

[
   {
     "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
   },
   ...
]

There are a few things to note about this:

关于这一点，有几点需要注意：

The JSON should always describe a list (even if empty), which should only contain objects.
The objects in the list should only contain properties with simple types (string / date / number / boolean or null).
The value of a property maycontain a comma - which makes parsing the JSON somewhat harder - but may notcontain any quotes (because I'm too lazy to deal with that).

JSON 应该总是描述一个列表（即使是空的），它应该只包含对象。
列表中的对象应该只包含简单类型的属性（字符串/日期/数字/布尔值或null）。
属性的值可能包含逗号 - 这使得解析 JSON 有点困难 - 但可能不包含任何引号（因为我懒得处理）。

The ParseListOfObjectsfunction in the code below takes the JSON string as input, and returns a Collectionrepresenting the items in the list. Each item is represented as a Dictionary, where the keys of the dictionary correspond to the names of the object's properties. The values are automatically converted to the appropriate type (String, Date, Double, Boolean- or Emptyif the value is null).

ParseListOfObjects下面代码中的函数将 JSON 字符串作为输入，并返回Collection表示列表中项目的。每个项目都表示为 a Dictionary，其中字典的键对应于对象属性的名称。这些值会自动转换为适当的类型（String、Date、Double、Boolean- 或者Empty如果值为null）。

Your VBA project will need a reference to the Microsoft Scripting Runtimelibrary to use the Dictionaryobject - though it would not be difficult to remove this dependency if you use a different way of encoding the results.

您的 VBA 项目将需要对Microsoft Scripting Runtime库的引用才能使用该Dictionary对象 - 尽管如果您使用不同的方式对结果进行编码，则删除此依赖项并不困难。

Here's my JSON.bas:

这是我的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

A simple test:

一个简单的测试：

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

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

Answer 7

回答by drgs

Another Regex based JSON parser (decode only)

另一个基于正则表达式的 JSON 解析器（仅解码）

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

Answer 8

回答by hector-j-rivas

Two small contributions to Codo's answer:

对Codo的回答的两个小贡献：

' "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

So now I can do stuff like:

所以现在我可以做这样的事情：

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

Answer 9

回答by bvj

Microsoft: Because VBScriptis a subset of Visual Basic for Applications,...

Microsoft：因为VBScript是 Visual Basic for Applications 的子集，...

The code below is derived from Codo's post should it also be helpful to have in class form, and usable as VBScript:

下面的代码源自 Codo 的帖子，如果以类形式使用也有帮助，并且可用作VBScript：

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

Usage:

用法：

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

Answer 10

回答by user2554274

Thanks a lot Codo.

非常感谢科多。

I've just updated and completed what you have done to :

我刚刚更新并完成了你所做的：

serialize the json (I need it to inject the json in a text-like document)

add, remove and update node (who knows)

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

序列化 json（我需要它在类似文本的文档中注入 json）

添加、删除和更新节点（谁知道）

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

在 Excel VBA 中解析 JSON

提问by Bastan

采纳答案by Codo

回答by omegastripes

回答by SIM

回答by ozmike

回答by Viktor Procházka

回答by Gary McGill

回答by drgs

回答by hector-j-rivas

回答by bvj

回答by user2554274

相关推荐

最近更新

标签

在 Excel VBA 中解析 JSON

提问by Bastan

采纳答案by Codo

回答by omegastripes

回答by SIM

回答by ozmike

回答by Viktor Procházka

回答by Gary McGill

回答by drgs

回答by hector-j-rivas

回答by bvj

回答by user2554274

相关推荐

用于将 PLIST 转换为 JSON 的命令行工具？

使用基本身份验证通过 CURL POST JSON

json ElasticSearch 获取索引名称和存储大小

使用 REST 协议和 JSON 数据格式测试 Web 服务的最佳工具是什么？

相关推荐

最近更新

标签