在Excel VBA代码中处理XMLHttp响应中的JSON对象

我需要处理Excel VBA中的XMLHTTPRequest的响应JSON对象。 我写下面的代码，但没有成功。 请指导我

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

我得到错误运行时错误'429'ActiveX组件不能创build对象在行Set sc = CreateObject("ScriptControl")

而且，一旦我们parsing了JOSN对象，如何访问JSON对象的值呢？

PS我的JSON对象示例： {"Success":true,"Message":"Blah blah"}

Answer 1

该代码从nseindia网站获取数据，该数据来自responseDiv元素中的JSONstring。

必需的参考

3类模块我已经使用

• cJSONScript
• cStringBuilder
• JSON

（我从这里select了这些类模块）

你可以从这个链接下载文件

标准模块

 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 

Answer 2

我在以下图书馆取得了很大的成功：

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

该库使用Scripting.Dictionary的对象和Collection的数组，我没有任何问题，parsing相当复杂的JSON文件。

至于你自己parsingjson的更多信息，看看这个问题的一些背景，围绕从sc.Eval调用返回的JScriptTypeInfo对象的问题：

Excel VBA：parsing的JSON对象循环

最后，对于使用XMLHTTPRequest一些有用的类，我的项目VBA-Web的一个小插件：

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

Answer 3

我知道这是一个老问题，但我已经创build了一个简单的方法来从Web请求与Json交互。 在哪里我也包装了networking请求。

可在这里

您需要将以下代码作为名为Json的class module

 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 

示例用法（来自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