Handle JSON Object in XMLHttp response in Excel VBA Code
The code gets the data from nseindia site which comes as a JSON string in responseDiv element.
Required References
3 Class Module i have used
- cJSONScript
- cStringBuilder
- JSON
(I have picked these class modules from here)
You may download the file from this link
Standard Module
Const URl As String = "http://www.nseindia.com/live_market/dynaContent/live_watch/get_quote/GetQuote.jsp?symbol=ICICIBANK"Sub xmlHttp() Dim xmlHttp As Object Set xmlHttp = CreateObject("MSXML2.ServerXMLHTTP.6.0") xmlHttp.Open "GET", URl & "&rnd=" & WorksheetFunction.RandBetween(1, 99), False xmlHttp.setRequestHeader "Content-Type", "text/xml" xmlHttp.send Dim html As MSHTML.HTMLDocument Set html = New MSHTML.HTMLDocument html.body.innerHTML = xmlHttp.ResponseText Dim divData As Object Set divData = html.getElementById("responseDiv") '?divData.innerHTML ' Here you will get a string which is a JSON data Dim strDiv As String, startVal As Long, endVal As Long strDiv = divData.innerHTML startVal = InStr(1, strDiv, "data", vbTextCompare) endVal = InStr(startVal, strDiv, "]", vbTextCompare) strDiv = "{" & Mid(strDiv, startVal - 1, (endVal - startVal) + 2) & "}" Dim JSON As New JSON Dim p As Object Set p = JSON.parse(strDiv) i = 1 For Each item In p("data")(1) Cells(i, 1) = item Cells(i, 2) = p("data")(1)(item) i = i + 1 Next End Sub
I've had a lot of success with the following library:
https://github.com/VBA-tools/VBA-JSON
The library uses Scripting.Dictionary for Objects and Collection for Arrays and I haven't had any issues with parsing pretty complex json files.
As for more info on parsing json yourself, check out this question for some background on issues surrounding the JScriptTypeInfo object returned from the sc.Eval call:
Excel VBA: Parsed JSON Object Loop
Finally, for some helpful classes for working with XMLHTTPRequest, a little plug for my project, VBA-Web:
I know this is an old question but I've created a simple way to interact with Json from web requests. Where i've wrapped the web request as well.
You need the following code as a class module called Json
Public Enum ResponseFormat Text JsonEnd EnumPrivate pResponseText As StringPrivate pResponseJsonPrivate pScriptControl As Object'Request method returns the responsetext and optionally will fill out json or xml objectsPublic Function request(url As String, Optional postParameters As String = "", Optional format As ResponseFormat = ResponseFormat.Json) As String Dim xml Dim requestType As String If postParameters <> "" Then requestType = "POST" Else requestType = "GET" End If Set xml = CreateObject("MSXML2.XMLHTTP") xml.Open requestType, url, False xml.setRequestHeader "Content-Type", "application/json" xml.setRequestHeader "Accept", "application/json" If postParameters <> "" Then xml.send (postParameters) Else xml.send End If pResponseText = xml.ResponseText request = pResponseText Select Case format Case Json SetJson End SelectEnd FunctionPrivate Sub SetJson() Dim qt As String qt = """" Set pScriptControl = CreateObject("scriptcontrol") pScriptControl.Language = "JScript" pScriptControl.eval "var obj=(" & pResponseText & ")" 'pScriptControl.ExecuteStatement "var rootObj = null" pScriptControl.AddCode "function getObject(){return obj;}" 'pScriptControl.eval "var rootObj=obj[" & qt & "query" & qt & "]" pScriptControl.AddCode "function getRootObject(){return rootObj;}" pScriptControl.AddCode "function getCount(){ return rootObj.length;}" pScriptControl.AddCode "function getBaseValue(){return baseValue;}" pScriptControl.AddCode "function getValue(){ return arrayValue;}" Set pResponseJson = pScriptControl.Run("getObject")End SubPublic Function setJsonRoot(rootPath As String) If rootPath = "" Then pScriptControl.ExecuteStatement "rootObj = obj" Else pScriptControl.ExecuteStatement "rootObj = obj." & rootPath End If Set setJsonRoot = pScriptControl.Run("getRootObject")End FunctionPublic Function getJsonObjectCount() getJsonObjectCount = pScriptControl.Run("getCount")End FunctionPublic Function getJsonObjectValue(path As String) pScriptControl.ExecuteStatement "baseValue = obj." & path getJsonObjectValue = pScriptControl.Run("getBaseValue")End FunctionPublic Function getJsonArrayValue(index, key As String) Dim qt As String qt = """" If InStr(key, ".") > 0 Then arr = Split(key, ".") key = "" For Each cKey In arr key = key + "[" & qt & cKey & qt & "]" Next Else key = "[" & qt & key & qt & "]" End If Dim statement As String statement = "arrayValue = rootObj[" & index & "]" & key pScriptControl.ExecuteStatement statement getJsonArrayValue = pScriptControl.Run("getValue", index, key)End FunctionPublic Property Get ResponseText() As String ResponseText = pResponseTextEnd PropertyPublic Property Get ResponseJson() ResponseJson = pResponseJsonEnd PropertyPublic Property Get ScriptControl() As Object ScriptControl = pScriptControlEnd PropertyExample Usage (from ThisWorkbook):
Sub Example() Dim j 'clear current range Range("A2:A1000").ClearContents 'create ajax object Set j = New Json 'make yql request for json j.request "https://query.yahooapis.com/v1/public/yql?q=show%20tables&format=json&callback=&diagnostics=true" 'Debug.Print j.ResponseText 'set root of data Set obj = j.setJsonRoot("query.results.table") Dim index 'determine the total number of records returned index = j.getJsonObjectCount 'if you need a field value from the object that is not in the array 'tempValue = j.getJsonObjectValue("query.created") Dim x As Long x = 2 If index > 0 Then For i = 0 To index - 1 'set cell to the value of content field Range("A" & x).value = j.getJsonArrayValue(i, "content") x = x + 1 Next Else MsgBox "No items found." End IfEnd Sub