Parsing JSON in Excel VBA

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 

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 

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 

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 

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.

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

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 

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 

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" 

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 

Using htmlfile&JSON.parse instead of ScriptControl&eval

JSON.parse is safer than eval and should be generally available as of 2023 (IE8+). These days I tend to use htmlfile instead of ScriptControl which isn't available in 64-bit Excel. Also you get JSON.stringify for free.

Dim jsonString jsonString = "{""SomeArray"":[{""SomeVal"": 42}]}" Dim htmlfile Set htmlfile = CreateObject("htmlfile") ' this ritual enables window.JSON htmlfile.write "<!DOCTYPE html><meta http-equiv='X-UA-Compatible' content='IE=edge'>" htmlfile.parentWindow.execScript ";" ' You might want to load Douglas Crockford's json2 library as a polyfill here if your users' environment is REALLY old ' HtmlFile.parentWindow.execScript LoadJSON2MinJS() Dim json Set json = htmlfile.parentWindow.json ' parse Dim obj Set obj = CallByName(json, "parse", VbMethod, jsonString) ' manipulation ' You still need to deal with getProperty stuff... CallByName(obj.SomeArray, 0, VbGet).SomeVal = "foo" ' stringify Dim str str = CallByName(json, "stringify", VbMethod, obj) Debug.Print str 

Here is some thin wrapper for readability:

Option Strict ' keep JSON all caps #If False Then Dim JSON #End If Private HtmlFile As Object Private JSON As Object Private Sub Init() If JSON Is Nothing Then Set HtmlFile = CreateObject("htmlfile") ' this ritual enables window.JSON HtmlFile.write "<!DOCTYPE html><meta http-equiv='X-UA-Compatible' content='IE=edge'>" HtmlFile.parentWindow.execScript ";" ' You might want to load Douglas Crockford's json2 library as a polyfill here if your users' environment is REALLY old ' HtmlFile.parentWindow.execScript LoadJSON2JS() Set JSON = HtmlFile.parentWindow.JSON End If End Sub Public Function JsonParse(ByVal jsonString As String) As Object Init Set JsonParse = CallByName(JSON, "parse", VbMethod, jsonString) End Function Public Function JsonStringify(ByVal jsonObject As Object) As String Init JsonStringify = CallByName(JSON, "stringify", VbMethod, jsonObject) End Function Public Function JsonValueAt(ByVal jsonObject As Object, ByVal index As Variant) As Variant JsonValueAt = CallByName(jsonObject, index, VbGet) End Function Public Function JsonObjectAt(ByVal jsonObject As Object, ByVal index As Variant) As Object Set JsonObjectAt = CallByName(jsonObject, index, VbGet) End Function Public Function JsonListLength(ByVal jsonList As Object) As Integer JsonListLength = JsonValueAt(jsonList, "length") End Function Public Sub JsonListClear(ByVal jsonList As Object) CallByName jsonList, "length", VbSet, 0 End Sub Public Sub JsonListPush(ByVal jsonList As Object, ByVal val As Object) CallByName jsonList, "push", VbMethod, val End Sub