16

我需要处理一个 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 + "')")

我收到错误Run-time error '429' ActiveX component can't create object in the line Set sc = CreateObject("ScriptControl")

一旦我们解析了 JSON 对象,您如何访问 JSON 对象的值?

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

4

3 回答 3

12

该代码从 nseindia 站点获取数据,该数据作为responseDiv元素中的 JSON 字符串提供。

所需的参考资料

在此处输入图像描述

我用过的 3 类模块

  • cJSONScript
  • cStringBuilder
  • JSON

(我从这里挑选了这些类模块)

您可以从此链接下载文件

标准模块

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
于 2013-05-31T07:15:38.393 回答
9

我在以下库中取得了很大的成功:

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

该库Scripting.Dictionary用于对象和Collection数组,我在解析非常复杂的 json 文件时没有任何问题。

至于有关自己解析 json 的更多信息,请查看此问题以了解有关从 sc.Eval 调用返回的 JScriptTypeInfo 对象的问题的一些背景:

Excel VBA:解析的 JSON 对象循环

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

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

于 2013-05-29T23:47:20.123 回答
3

我知道这是一个老问题,但我创建了一种简单的方式来与JsonWeb 请求进行交互。我也在哪里包装了网络请求。

在这里可用

您需要以下代码作为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
于 2016-07-15T14:41:53.793 回答