在 Excel VBA 代码中处理 XMLHttp 响应中的 JSON 对象
Posted
技术标签:
【中文标题】在 Excel VBA 代码中处理 XMLHttp 响应中的 JSON 对象【英文标题】:Handle JSON Object in XMLHttp response in Excel VBA Code 【发布时间】:2013-05-24 22:18:07 【问题描述】:我需要处理一个 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 + "')")
我在Set sc = CreateObject("ScriptControl")
行中收到错误Run-time error '429' ActiveX component can't create object
一旦我们解析了 JSON 对象,你如何访问 JSON 对象的值?
附:我的 JSON 对象示例:"Success":true,"Message":"Blah blah"
【问题讨论】:
能否提供要拉取数据的链接和id。 或许可以试试Set sc = CreateObject("MSScriptControl.ScriptControl")
@Santosh,它不是在线链接......现在是本地主机。我没有任何在线链接可以 ping 并获得结果。
@barrowc 试过了。没有运气:( :(
要访问诸如 array.item(0) 之类的项目,请参阅此帖子***.com/questions/5773683/…
【参考方案1】:
我知道这是一个老问题,但我创建了一种简单的方法来通过网络请求与 Json
进行交互。我也在哪里包装了网络请求。
Available here
您需要以下代码作为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
示例用法(来自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
【讨论】:
这可能很危险,因为它允许运行 javascript 代码。 @LS_ᴅᴇᴠ 你认为什么会很危险? 我猜想在 eval 函数中有些东西,但实际上,除非你信任来源,否则你不应该使用它。【参考方案2】:我在以下库方面取得了很大的成功:
https://github.com/VBA-tools/VBA-JSON
该库使用Scripting.Dictionary
表示对象,Collection
表示数组,我在解析相当复杂的 json 文件时没有遇到任何问题。
关于自己解析 json 的更多信息,请查看此问题以了解有关从 sc.Eval 调用返回的 JScriptTypeInfo 对象的问题的一些背景:
Excel VBA: Parsed JSON Object Loop
最后,对于使用XMLHTTPRequest
的一些有用的类,我的项目VBA-Web 的一个小插件:
https://github.com/VBA-tools/VBA-Web
【讨论】:
你能看看***.com/questions/26229563/…吗?【参考方案3】:代码从 nseindia 站点获取数据,该数据以 JSON 字符串形式出现在 responseDiv
元素中。
必填参考文献
我用过的3个类模块
cJSONScript cStringBuilder JSON(我从here中挑选了这些类模块)
您可以从此link下载文件
标准模块
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
【讨论】:
@Santhosh 你试过了吗? 抱歉回复晚了..我已经使用我的代码添加了所需的引用...没有运气:(...我没有尝试您的代码...我会尝试让你知道。 谢谢你!你帮了我很大的忙! @ONDEV 很高兴这篇文章对您有所帮助!干杯:) @Santosh 我收到“无效的过程或调用参数”。以上是关于在 Excel VBA 代码中处理 XMLHttp 响应中的 JSON 对象的主要内容,如果未能解决你的问题,请参考以下文章