在 Excel VBA 中解析 JSON
Posted
技术标签:
【中文标题】在 Excel VBA 中解析 JSON【英文标题】：Parsing JSON in Excel VBA 【发布时间】：2011-10-01 10:37:13 【问题描述】：我遇到了与Excel VBA: Parsed JSON Object Loop 相同的问题，但找不到任何解决方案。我的 JSON 具有嵌套对象，因此建议的解决方案（如 VBJSON 和 vba-json）对我不起作用。我还修复了其中一个以使其正常工作，但结果是由于 doProcess 函数的多次递归而导致调用堆栈溢出。
最好的解决方案似乎是原始帖子中看到的 jsonDecode 函数。它非常快速且高效；我的对象结构都存在于 JScriptTypeInfo 类型的通用 VBA 对象中。
此时的问题是我无法确定对象的结构，因此，我事先不知道每个通用对象中的键。我需要遍历通用 VBA 对象来获取键/属性。
如果我解析 javascript 函数可以触发 VBA 函数或子函数，那就太好了。
【问题讨论】：
我记得你之前的问题，所以再次看到它很有趣。我会遇到的一个问题是：假设您成功地在 VBA 中解析了 JSON - 那么您将如何在 VBA 中使用该“对象”？您注意到 JSON 结构可以是任何类型，那么您将如何在 VBA 中导航最终结果？我的第一个想法可能是创建一个 JScript 来解析 JSON（使用 eval 甚至是“更好”的现有库之一），然后遍历该结构以生成一个基于嵌套脚本字典的对象以传回 VBA。你在用你解析的 JSON 做什么？ github.com/akaZorg/asp-xtreme-evolution/blob/master/app/core/… 可能有用 我将为每个对象创建一个工作表并在每一行添加记录，如果不存在则创建列（附加在第 1 行中）。您建议的 asp-xtreme-evoluton 似乎很有趣。正在创造一些非常相似的东西。我已经获得了 vba-json 类的固定且几乎可以正常工作（我修复了这个小“问题”）。我们将暂时使用它。工作的 vba-json 由相关问题的作者 Randyr 提供。 @tim，我之前的评论可能无法正确回答您的问题。我知道该结构基本上是带有记录的表的列表。所以我有一个代表表格的对象（键：值）。 “键”是表名，值是对象（键：值）的记录的数组 []。我不知道提供了哪个表以及哪些列（字段）可用。对于不能没有严格结构的人来说，这是狂野的通用编程:-) 当然不会冒犯任何人。 如果结构相似但“键”不同，则更容易理解。出于兴趣，数据来自哪里？ 【参考方案1】：如果你想在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
几点说明：
如果JScriptTypeInfo 实例引用了一个Javascript 对象，For Each ... Next 将不起作用。但是，如果它引用 Javascript 数组，它确实可以工作（请参阅GetKeys 函数）。
名称仅在运行时知道的访问属性，使用函数GetProperty 和GetObjectProperty。
Javascript 数组提供属性length、0、Item 0、1、Item 1 等。使用 VBA 点表示法 (jsonObject.property)，只有长度属性是可访问的，并且仅当你声明了一个名为length 的变量，所有字母都是小写的。否则，案例不匹配，它不会找到它。其他属性在 VBA 中无效。所以最好使用GetProperty 函数。
代码使用早期绑定。所以你必须添加对“Microsoft Script Control 1.0”的引用。
在使用其他函数进行一些基本初始化之前，您必须调用一次InitScriptEngine。
【讨论】：
这个答案似乎是我想要的，但在尝试DecodeJsonString 函数时我得到了一个object variable not set。除了 Microsoft Script Control，我还需要其他参考吗？
如果缺少参考，您会收到不同的错误消息。错误发生在哪一行？该行中使用的变量的值是多少？
它出现在Set DecodeJsonString = ScriptEngine.Eval("(" + JsonString + ")") 行之后。 JsonString 只是一个普通的 json 对象。我尝试了各种 Json 对象并得到相同的错误。
有史以来最好的答案。我刚刚完成了关于如何调用 JSON Restful 服务的 POC，根据您的答案解析收到的 json，然后将其显示在 Excel 中。我们的客户对此非常满意。非常感谢 。为此 +1 ..
我通过剥离类型并使用以下代码进行初始化，使您的解决方案适用于 VBScript：Set se = CreateObject("MSScriptControl.ScriptControl")。 +1 谢谢！【参考方案2】：
更新 3（2017 年 9 月 24 日）
查看VBA-JSON-parser on GitHub 以获取最新版本和示例。 将JSON.bas模块导入VBA项目进行JSON处理。
更新 2（2016 年 10 月 1 日）
但是，如果您确实想在 64 位 Office 上使用 ScriptControl 解析 JSON，那么 this answer 可能会帮助您让 ScriptControl 在 64 位上工作。
更新（2015 年 10 月 26 日）
请注意，基于ScriptControl 的方法在某些情况下会使系统易受攻击，因为它们允许通过 ActiveX 直接访问恶意 JS 代码的驱动器（和其他东西）。假设您正在解析 Web 服务器响应 JSON，例如 JsonString = "a:(function()(new ActiveXObject('Scripting.FileSystemObject')).CreateTextFile('C:\\Test.txt'))()"。评估后你会发现新创建的文件C:\Test.txt。所以用ScriptControlActiveX 解析 JSON 并不是一个好主意。
为了避免这种情况，我创建了基于 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+\w3>"
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+\w3>"
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+\w3>"
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
此 JSON RegEx 解析器的另一个机会是它可以在 ScriptControl 不可用的 64 位 Office 上工作。
首字母（2015 年 5 月 27 日）
这是在 VBA 中解析 JSON 的另一种方法，基于 ScriptControl ActiveX，无需外部库：
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
【讨论】：
第二个正则表达式版本是迄今为止我见过的最疯狂的实现。该代码中发生了什么？我有自己的基于正则表达式的解析器（仅解码），我在下面发布了 道歉是密集的，但在更新版本中，varJson、strState 来自哪里？我似乎使用了它们，但没有分配除默认值以外的任何东西。或者这就是重点？您只对基于类型的处理感兴趣？ @QHarrvarJson 和strState 被传递ByRef，在Sub ParseJson() 中赋值给它们，并作为解析的结果返回。
@omegastripes 傻我。我应该向下滚动。感谢您的澄清。
VBA-JSON 作者有一个插入式 Scripting.Dictionary 替换 github.com/VBA-tools/VBA-Dictionary。在这种情况下，您不需要脚本运行时。感谢@TimWilliams 提供此信息。【参考方案3】：
由于 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
【讨论】：
在循环中添加第三个参数Split(<string>, <delimiter>, 2)，如果需要单个结果，可能会提高性能。
这应该是最佳答案。在尝试了几个小时的其他尝试后，我在 10 分钟内完成了这项工作。简单有效。我想指出，这需要添加“Microsoft XML，V6”引用才能工作。
@MrXsquared 这是一种幼稚的方法，但它可以使用某些形式的非常简单的 JSON。如果它适用于您的场景并且您喜欢它，那就试试吧。只需准备好频繁处理递归 JSON。【参考方案4】：
在 VB 代码中使用 array.myitem(0) 的更简单方法
my full answer here parse and stringify (serialize)
在js中使用'this'对象
ScriptEngine.AddCode "Object.prototype.myitem=function( i ) return this[i] ; "
然后你可以去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
【讨论】：
【参考方案5】：为了在 VBA 中解析 JSON 而不向您的工作簿项目添加庞大的库，我创建了以下解决方案。它速度极快，并将所有键和值存储在字典中以便于访问：
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
上面的代码确实使用了一些辅助函数，但上面是它的精髓。
这里使用的策略是使用递归分词器。我发现在 Medium 上写一个 article about this solution 很有趣。它解释了细节。
这是完整的（但令人惊讶的简短）代码清单，包括所有帮助函数：
'-------------------------------------------------------------------
' 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
【讨论】：
【参考方案6】：这适用于我在 Excel 和使用转换为本机形式的 JSON 查询的大型 JSON 文件下。 https://github.com/VBA-tools/VBA-JSON 我能够解析像“item.something”这样的节点并使用简单的命令获取值：
MsgBox Json("item")("something")
有什么好看的。
【讨论】：
【参考方案7】：Microsoft：因为 VBScript 是 Visual Basic 的子集 应用程序，...
下面的代码来自 Codo 的帖子，如果它在类形式中也有帮助，并且可用作 VBScript：
class JsonParser
' adapted from: http://***.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
用法：
set jp = new JsonParser
set jo = jp.Decode("value: true")
keys = jp.EnumKeys(jo)
value = jp.GetValue(jo, "value")
【讨论】：
如何在嵌套的 JSON 结构中工作，例如包含不同数据类型的字典集合？ 好问题，@QHarr 也许可以引入一个值类，用于构建数据的对象树。例如，如果检测到左大括号，则执行后续解析。 感谢您回复我！【参考方案8】：非常感谢科多。
我刚刚更新并完成了你所做的：
序列化 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
【讨论】：
感谢您发布此代码。我有一个多记录 JSON 字符串，例如： ""key1"": ""val1"", ""key2"": ""key3"": ""val3"" ,"""key1" ": ""val11"", ""key2"": ""key3"": ""val33"" 你能告诉我如何遍历所有记录吗？任何帮助将不胜感激。跨度> 【参考方案9】：对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
所以现在我可以执行以下操作：
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
【讨论】：
【参考方案10】：这里有很多很好的答案 - 只是我自己的。
我需要解析一个非常具体的 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
,
...
]
有几点需要注意：
-
JSON 应该总是描述一个列表（即使是空的），它应该只包含对象。
列表中的对象应该只包含简单类型的属性（字符串/日期/数字/布尔值或
null）。
属性的值可能包含一个逗号 - 这使得解析 JSON 有点困难 - 但可能 不 包含任何引号（因为我懒得处理与那个）。
下面代码中的ParseListOfObjects 函数将JSON 字符串作为输入，并返回一个Collection 代表列表中的项目。每个项目都表示为Dictionary，其中字典的键对应于对象属性的名称。这些值会自动转换为适当的类型（String、Date、Double、Boolean - 或 Empty，如果值为 null）。
您的 VBA 项目将需要对 Microsoft Scripting Runtime 库的引用才能使用 Dictionary 对象 - 尽管如果您使用不同的结果编码方式，删除这种依赖关系并不难。
这是我的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
一个简单的测试：
Const strJSON As String = "[""property1"":""foo""]"
Dim oObjects As Collection: Set oObjects = Json.ParseListOfObjects(strJSON)
MsgBox oObjects(1)("property1") ' shows "foo"
【讨论】：
【参考方案11】：另一个基于正则表达式的 JSON 解析器（仅解码）
Option Explicit
Private Enum JsonStep
jstUnexpected
jstString
jstNumber
jstTrue
jstFalse
jstNull
jstOpeningBrace
jstClosingBrace
jstOpeningBracket
jstClosingBracket
jstComma
jstColon
jstWhitespace
End Enum
Private gobjRegExpJsonStep As Object
Private gobjRegExpUnicodeCharacters As Object
Private gobjTokens As Object
Private k As Long
Private Function JsonStepName(ByRef jstStep As JsonStep) As String
Select Case jstStep
Case jstString: JsonStepName = "'STRING'"
Case jstNumber: JsonStepName = "'NUMBER'"
Case jstTrue: JsonStepName = "true"
Case jstFalse: JsonStepName = "false"
Case jstNull: JsonStepName = "null"
Case jstOpeningBrace: JsonStepName = "''"
Case jstClosingBrace: JsonStepName = "''"
Case jstOpeningBracket: JsonStepName = "'['"
Case jstClosingBracket: JsonStepName = "']'"
Case jstComma: JsonStepName = "','"
Case jstColon: JsonStepName = "':'"
Case jstWhitespace: JsonStepName = "'WHITESPACE'"
Case Else: JsonStepName = "'UNEXPECTED'"
End Select
End Function
Private Function Unescape(ByVal strText As String) As String
Dim objMatches As Object
Dim i As Long
strText = Replace$(strText, "\""", """")
strText = Replace$(strText, "\\", "\")
strText = Replace$(strText, "\/", "/")
strText = Replace$(strText, "\b", vbBack)
strText = Replace$(strText, "\f", vbFormFeed)
strText = Replace$(strText, "\n", vbCrLf)
strText = Replace$(strText, "\r", vbCr)
strText = Replace$(strText, "\t", vbTab)
If gobjRegExpUnicodeCharacters Is Nothing Then
Set gobjRegExpUnicodeCharacters = CreateObject("VBScript.RegExp")
With gobjRegExpUnicodeCharacters
.Global = True
.Pattern = "\\u([0-9a-fA-F]4)"
End With
End If
Set objMatches = gobjRegExpUnicodeCharacters.Execute(strText)
For i = 0 To objMatches.Count - 1
With objMatches(i)
strText = Replace$(strText, .Value, ChrW$(Val("&H" + .SubMatches(0))), , 1)
End With
Next i
Unescape = strText
End Function
Private Sub Tokenize(ByRef strText As String)
If gobjRegExpJsonStep Is Nothing Then
Set gobjRegExpJsonStep = CreateObject("VBScript.RegExp")
With gobjRegExpJsonStep
.Pattern = "(""((?:[^\\""]+|\\[""\\/bfnrt]|\\u[0-9a-fA-F]4)*)""|" & _
"(-?(?:0|[1-9]\d*)(?:\.\d+)?(?:[eE][-+]?\d+)?)|" & _
"(true)|" & _
"(false)|" & _
"(null)|" & _
"(\)|" & _
"(\)|" & _
"(\[)|" & _
"(\])|" & _
"(\,)|" & _
"(:)|" & _
"(\s+)|" & _
"(.+?))"
.Global = True
End With
End If
Set gobjTokens = gobjRegExpJsonStep.Execute(strText)
End Sub
Private Function ErrorMessage(ByRef vntExpecting As Variant) As String
Dim lngLB As Long
Dim lngUB As Long
Dim i As Long
Dim jstJsonStep As JsonStep
Dim strResult As String
If Rank(vntExpecting) = 1 Then
lngLB = LBound(vntExpecting)
lngUB = UBound(vntExpecting)
If lngLB <= lngUB Then
strResult = "Expecting "
For i = lngLB To lngUB
jstJsonStep = vntExpecting(i)
If i > lngLB Then
If i < lngUB Then
strResult = strResult & ", "
Else
strResult = strResult & " or "
End If
End If
strResult = strResult & JsonStepName(jstJsonStep)
Next i
End If
End If
If strResult = "" Then
strResult = "Unexpected error"
End If
If gobjTokens.Count > 0 Then
If k < gobjTokens.Count Then
strResult = strResult & " at position " & (gobjTokens(k).FirstIndex + 1) & "."
Else
strResult = strResult & " at EOF."
End If
Else
strResult = strResult & " at position 1."
End If
ErrorMessage = strResult
End Function
Private Function ParseStep(ByRef vntValue As Variant) As JsonStep
Dim i As Long
k = k + 1
If k >= gobjTokens.Count Then
vntValue = Empty
Exit Function
End If
With gobjTokens(k)
For i = 1 To 12
If Not IsEmpty(.SubMatches(i)) Then
ParseStep = i
Exit For
End If
Next i
Select Case ParseStep
Case jstString
vntValue = Unescape(.SubMatches(1))
Case jstNumber
vntValue = Val(.SubMatches(2))
Case jstTrue
vntValue = True
Case jstFalse
vntValue = False
Case jstNull
vntValue = Null
Case jstWhitespace
ParseStep = ParseStep(vntValue)
Case Else
vntValue = Empty
End Select
End With
End Function
Private Function ParseObject(ByRef vntObject As Variant) As Boolean
Dim strKey As String
Dim vntValue As Variant
Dim objResult As Object
Set objResult = CreateObject("Scripting.Dictionary")
Do
Select Case ParseStep(strKey)
Case jstString
If Not ParseStep(Empty) = jstColon Then
LogError "ParseObject", ErrorMessage(Array(jstColon))
Exit Function
End If
Select Case ParseStep(vntValue)
Case jstString, jstNumber, jstTrue, jstFalse, jstNull
objResult.Item(strKey) = vntValue
Case jstOpeningBrace
If ParseObject(vntValue) Then
Set objResult.Item(strKey) = vntValue
End If
Case jstOpeningBracket
If ParseArray(vntValue) Then
Set objResult.Item(strKey) = vntValue
End If
Case Else
LogError "ParseObject", ErrorMessage(Array(jstString, jstNumber, jstTrue, jstFalse, jstNull, jstOpeningBrace, jstOpeningBracket))
Exit Function
End Select
Select Case ParseStep(Empty)
Case jstComma
'Do nothing
Case jstClosingBrace
Set vntObject = objResult
ParseObject = True
Exit Function
Case Else
LogError "ParseObject", ErrorMessage(Array(jstComma, jstClosingBrace))
Exit Function
End Select
Case jstClosingBrace
Set vntObject = objResult
ParseObject = True
Exit Function
Case Else
LogError "ParseObject", ErrorMessage(Array(jstString, jstClosingBrace))
Exit Function
End Select
Loop While True
End Function
Private Function ParseArray(ByRef vntArray As Variant) As Boolean
Dim vntValue As Variant
Dim colResult As Collection
Set colResult = New Collection
Do
Select Case ParseStep(vntValue)
Case jstString, jstNumber, jstTrue, jstFalse, jstNull
colResult.Add vntValue
Case jstOpeningBrace
If ParseObject(vntArray) Then
colResult.Add vntArray
End If
Case jstOpeningBracket
If ParseArray(vntArray) Then
colResult.Add vntArray
End If
Case jstClosingBracket
Set vntArray = colResult
ParseArray = True
Exit Function
Case Else
LogError "ParseArray", ErrorMessage(Array(jstString, jstNumber, jstTrue, jstFalse, jstNull, jstOpeningBrace, jstOpeningBracket, jstClosingBracket))
Exit Function
End Select
Select Case ParseStep(Empty)
Case jstComma
'Do nothing
Case jstClosingBracket
Set vntArray = colResult
ParseArray = True
Exit Function
Case Else
LogError "ParseArray", ErrorMessage(Array(jstComma, jstClosingBracket))
Exit Function
End Select
Loop While True
End Function
Public Function ParseJson(ByRef strText As String, _
ByRef objJson As Object) As Boolean
Tokenize strText
k = -1
Select Case ParseStep(Empty)
Case jstOpeningBrace
ParseJson = ParseObject(objJson)
Case jstOpeningBracket
ParseJson = ParseArray(objJson)
Case Else
LogError "ParseJson", ErrorMessage(Array(jstOpeningBrace, jstOpeningBracket))
End Select
End Function
【讨论】：
以上是关于在 Excel VBA 中解析 JSON的主要内容，如果未能解决你的问题，请参考以下文章
在 Excel 中解析 ISO8601 日期/时间（包括 TimeZone）