Handle JSON Object in XMLHttp response in Excel VBA Code

Question

I need to handle a JSON Object which is the response of XMLHTTPRequest in Excel VBA. I wrote the code below, but it doesn't work:

 Dim sc As Object Set sc = CreateObject("ScriptControl") sc.Language = "JScript" Dim strURL As String: strURL = "blah blah" Dim strRequest Dim XMLhttp: Set XMLhttp = CreateObject("msxml2.xmlhttp") Dim response As String XMLhttp.Open "POST", strURL, False XMLhttp.setrequestheader "Content-Type", "application/x-www-form-urlencoded" XMLhttp.send strRequest response = XMLhttp.responseText sc.Eval ("JSON.parse('" + response + "')")

I am getting the error Run-time error '429' ActiveX component can't create object in the line Set sc = CreateObject("ScriptControl")

Once we parsed the JSON Object, how do you access the values of the JSON Object?

P.S. My JSON Object sample: {"Success":true,"Message":"Blah blah"}

Perhaps try Set sc = CreateObject("MSScriptControl.ScriptControl") — barrowc
– barrowc, Commented May 29, 2013 at 16:27
@Santosh, it is not an online link... localhost now. I don't have any online links to ping and get the result. — Santhosh
– Santhosh, Commented May 30, 2013 at 4:08
To access items eg array.item(0) see this post stackoverflow.com/questions/5773683/… — ozmike
– ozmike, Commented Oct 14, 2013 at 12:51

Santosh · Accepted Answer · 2013-05-31 07:15:38Z

The code gets the data from nseindia site which comes as a JSON string in responseDiv element.

Required References

enter image description here

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

Sorry for the late reply.. I have already added the required references using my code... No luck :( ... I did not try your code... I will try and let you know.

Community · Accepted Answer · 2017-05-23 12:02:02Z

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:

https://github.com/VBA-tools/VBA-Web

Can you please take a look at stackoverflow.com/questions/26229563/…?

weeksdev · Accepted Answer · 2016-07-15 14:41:53Z

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.

Available here

You need the following code as a class module called Json

Public Enum ResponseFormat Text Json End Enum Private pResponseText As String Private pResponseJson Private pScriptControl As Object 'Request method returns the responsetext and optionally will fill out json or xml objects Public 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 Select End Function Private 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 Sub Public 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 Function Public Function getJsonObjectCount() getJsonObjectCount = pScriptControl.Run("getCount") End Function Public Function getJsonObjectValue(path As String) pScriptControl.ExecuteStatement "baseValue = obj." & path getJsonObjectValue = pScriptControl.Run("getBaseValue") End Function Public 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 Function Public Property Get ResponseText() As String ResponseText = pResponseText End Property Public Property Get ResponseJson() ResponseJson = pResponseJson End Property Public Property Get ScriptControl() As Object ScriptControl = pScriptControl End Property

Example 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 If End Sub

i guess in the eval function something there, but really, you shouldn't use this unless you trust the source.

Collectives™ on Stack Overflow

Handle JSON Object in XMLHttp response in Excel VBA Code

3 Answers 3

5 Comments

1 Comment

3 Comments

Linked

Hot Network Questions