Parsing JSON in Excel VBA

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 ExplicitPrivate ScriptEngine As ScriptControlPublic 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 SubPublic Function DecodeJsonString(ByVal JsonString As String)    Set DecodeJsonString = ScriptEngine.Eval("(" + JsonString + ")")End FunctionPublic Function GetProperty(ByVal JsonObject As Object, ByVal propertyName As String) As Variant    GetProperty = ScriptEngine.Run("getProperty", JsonObject, propertyName)End FunctionPublic Function GetObjectProperty(ByVal JsonObject As Object, ByVal propertyName As String) As Object    Set GetObjectProperty = ScriptEngine.Run("getProperty", JsonObject, propertyName)End FunctionPublic 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 = KeysArrayEnd FunctionPublic 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.

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 ExplicitSub 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 SubSub 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, , 64End SubSub 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 WithEnd SubSub 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 WithEnd SubSub 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 WithEnd SubFunction BeautifyJson(varJson As Variant) As String    Dim strResult As String    Dim lngIndent As Long    BeautifyJson = ""    lngIndent = 0    BeautyTraverse BeautifyJson, lngIndent, varJson, vbTab, 1End FunctionSub 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 SelectEnd SubFunction 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 WithEnd FunctionSub WriteTextFile(strContent As String, strPath As String, lngFormat As Long)    With CreateObject("Scripting.FileSystemObject").OpenTextFile(strPath, 2, True, lngFormat)        .Write (strContent)        .Close    End WithEnd 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 SelectEnd SubFunction 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 WithEnd FunctionFunction 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 = FalseEnd 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 REnd Sub