Rączka Obiekt JSON w odpowiedzi XMLHttp w Excelu Kod VBA

Question

Potrzebuję obsługi obiektu JSON, który jest odpowiedzią XMLHTTPRequest w Excel VBA. Napisałem poniżej kod, ale się nie udało. Proszę, prowadź mnie.

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

Dostaję błąd Run-time error komponent '429' ActiveX nie może utworzyć obiektu w linii Set sc = CreateObject("ScriptControl")

I Kiedy analizowany obiekt JOSN, jak uzyskać dostęp do wartości obiektu JSON?

P.S. Moja próbka JSON obiektu: {"Success":true,"Message":"Blah blah"}

Answer 1

Kod pobiera dane z nseindia miejscu który pojawia się jako ciąg JSON w elemencie responseDiv.

Wymagane Referencje

3 moduł klasy I zostało użyte

• cJSONScript
• cStringBuilder
• JSON

(I wybrali tych modułów klasy z here)

Możesz pobrać plik z tego link

Standardowy moduł

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

miałem wiele sukcesów z następującym Biblioteka:

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

Biblioteka używa Scripting.Dictionary dla obiektów i Collection dla tablic i nie miałem żadnych problemów z parsowaniem dość złożonych plików json.

Jak uzyskać więcej informacji na temat analizowania JSON siebie, sprawdź to pytanie dla niektórych na tle zagadnień związanych z przedmiotem JScriptTypeInfo wrócił z rozmowy sc.Eval:

Excel VBA: Parsed JSON Object Loop

Wreszcie, dla niektórych pomocnych dla klas pracy z XMLHTTPRequest, trochę wtyczką dla mojego projektu, VBA-Web:

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

Answer 3

wiem, że to jest stare pytanie, ale Stworzyłem prosty sposób interakcji z Json z żądaniami internetowymi. Tam też zawinąłem żądanie sieci.

Available here

Trzeba następujący kod jako class module nazwie 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 

Przykład użycia (od 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