Parsing JSON in Excel VBA

I have the same issue as in Excel VBA: Parsed JSON Object Loop but 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.

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

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.

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

169114 次浏览
小开
最佳答案

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

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 JScriptTypeInfo instance refers to a Javascript object, For Each ... Next won't work. However, it does work if it refers to a Javascript array (see GetKeys function).
  • The access properties whose name is only known at run-time, use the functions GetProperty and GetObjectProperty.
  • The Javascript array provides the properties length, 0, Item 0, 1, Item 1 etc. With the VBA dot notation (jsonObject.property), only the length property is accessible and only if you declare a variable called length with 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 GetProperty function.
  • The code uses early binding. So you have to add a reference to "Microsoft Script Control 1.0".
  • You have to call InitScriptEngine once before using the other functions to do some basic initialization.
小开

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
小开

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

my full answer here parse and stringify (serialize)

Use the 'this' object in js

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

Then you can go 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
小开

UPDATE 3 (Sep 24 '17)

Check VBA-JSON-parser on GitHub for the latest version and examples. Import JSON.bas module into the VBA project for JSON processing.

UPDATE 2 (Oct 1 '16)

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

UPDATE (Oct 26 '15)

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 ScriptControl ActiveX is not a good idea.

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:

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.

INITIAL (May 27 '15)

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

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
小开

Microsoft: Because VBScript is a subset of 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:

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")
小开

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.

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
小开

Another Regex based JSON parser (decode only)

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
小开

Two small contributions to Codo's answer:

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

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-JSON I am able parse node like "item.something" and get value using simple command: 

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

What's nice.

小开

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:

[
{
"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:

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

The ParseListOfObjects function in the code below takes the JSON string as input, and returns a Collection representing 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 Empty if the value is null).

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

Here's my 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"
小开

To parse JSON in VBA without adding a huge library to your workbook project, I created the following solution. It's extremely fast and stores all of the keys and values in a dictionary for easy access:

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

The code above does use a few helper functions, but the above is the meat of it.

The strategy used here is to employ a recursive tokenizer. I found it interesting enough to write an article about this solution on Medium. It explains the details.

Here is the full (yet surprisingly short) code listing, including all of the helper functions:

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

提交答案