Xử lý đối tượng JSON trong phản hồi XMLHttp trong Mã VBA Excel

Question

Tôi cần xử lý đối tượng JSON là phản hồi của XMLHTTPRequest trong Excel VBA. Tôi đã viết mã dưới đây nhưng không thành công. Xin vui lòng hướng dẫn cho tôi.

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

Tôi nhận được lỗi Run-time error '429' ActiveX thành phần không thể tạo đối tượng trong dòng Set sc = CreateObject("ScriptControl")

Và, khi chúng ta phân tích các đối tượng JOSN, làm thế nào để truy cập vào các giá trị của đối tượng JSON?

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

Answer 1

các mã được dữ liệu từ trang web nseindia có dạng chuỗi JSON trong phần tử responseDiv.

Yêu cầu Tài liệu tham khảo

3 lớp Mô-đun tôi đã sử dụng

• cJSONScript
• cStringBuilder
• JSON

(Tôi đã chọn những mô-đun lớp từ here)

Bạn có thể tải về các tập tin từ link

Chuẩn Mô-đun này

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

Tôi đã có rất nhiều thành công với các thư viện sau:

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

Thư viện sử dụng Scripting.Dictionary cho các đối tượng và Collection cho Mảng và tôi đã không có bất kỳ vấn đề với phân tích các tệp json khá phức tạp.

Như để biết thêm về phân tích cú pháp json mình, hãy kiểm tra câu hỏi này cho một số nền tảng về các vấn đề xung quanh đối tượng JScriptTypeInfo trở về từ cuộc gọi sc.Eval:

Excel VBA: Parsed JSON Object Loop

Cuối cùng, đối với một số các lớp học hữu ích cho làm việc với XMLHTTPRequest, một chút cắm cho dự án của tôi, VBA-Web:

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

Answer 3

Tôi biết đây là một câu hỏi cũ nhưng Tôi đã tạo một cách đơn giản để tương tác với Json từ các yêu cầu web. Tôi cũng đã bao gồm yêu cầu web.

Available here

Bạn cần đoạn mã sau như một class module gọi 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 

Ví dụ sử dụng (từ 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