在 Excel VBA 代码中处理 XMLHttp 响应中的 JSON 对象
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/16817545/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Handle JSON Object in XMLHttp response in Excel VBA Code
提问by Santhosh
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:
我需要处理一个 JSON 对象，它是 Excel VBA 中 XMLHTTPRequest 的响应。我写了下面的代码，但它不起作用：
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 objectin the line Set sc = CreateObject("ScriptControl")
我收到错误运行时错误 '429' ActiveX 组件无法在行中 创建对象Set sc = CreateObject("ScriptControl")
Once we parsed the JSON Object, how do you access the values of the JSON Object?
一旦我们解析了 JSON 对象，您如何访问 JSON 对象的值？
P.S. My JSON Object sample: {"Success":true,"Message":"Blah blah"}
PS我的JSON对象示例： {"Success":true,"Message":"Blah blah"}
采纳答案by Santosh
The code gets the data from nseindia site which comes as a JSON string in responseDivelement.
该代码从 nseindia 站点获取数据，该数据作为responseDiv元素中的 JSON 字符串出现。
Required References
所需参考资料
3 Class Module i have used
我使用过的 3 个类模块
- cJSONScript
- cStringBuilder
- JSON
- JSONScript
- 字符串生成器
- 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
回答by Tim Hall
I've had a lot of success with the following library:
我在以下库中取得了很大的成功：
https://github.com/VBA-tools/VBA-JSON
https://github.com/VBA-tools/VBA-JSON
The library uses Scripting.Dictionaryfor Objects and Collectionfor Arrays and I haven't had any issues with parsing pretty complex json files.
该库Scripting.Dictionary用于对象和Collection数组，我在解析非常复杂的 json 文件时没有遇到任何问题。
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:
至于有关自己解析 json 的更多信息，请查看此问题以了解有关从 sc.Eval 调用返回的 JScriptTypeInfo 对象问题的一些背景知识：
Excel VBA: Parsed JSON Object Loop
Finally, for some helpful classes for working with XMLHTTPRequest, a little plug for my project, VBA-Web:
最后，对于一些有用的类XMLHTTPRequest，我的项目 VBA-Web 的一个小插件：
回答by weeksdev
I know this is an old question but I've created a simple way to interact with Jsonfrom web requests. Where i've wrapped the web request as well.
我知道这是一个老问题，但我创建了一种简单的方法来与JsonWeb 请求进行交互。我也包装了网络请求。
You need the following code as a class modulecalled Json
您需要以下代码作为class module调用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):
示例用法（来自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
