Excel VBA 코드의 XMLHttp 응답에서 JSON 개체 처리

Excel VBA 코드의 XMLHttp 응답에서 JSON 개체 처리

엑셀 VBA에서 XMLHTTPRequest의 응답인 JSON Object를 처리해야 합니다.아래 코드를 작성했는데 작동하지 않습니다.

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

런타임 오류 '429' ActiveX 구성 요소가 라인에 개체를 생성할 수 없습니다.라는 오류가 발생합니다.Set sc = CreateObject("ScriptControl")

JSON Object를 구문 분석한 후 JSON Object의 값에 액세스하려면 어떻게 해야 합니까?

추신: My JSON Object 샘플:{"Success":true,"Message":"Blah blah"}

코드는 JSON 문자열로 제공되는 nseindia 사이트에서 데이터를 가져옵니다.responseDiv원소의

필수 참조 자료

내가 사용한 3개의 클래스 모듈

• cJSON스크립트
• cStringBuilder
• 제이손

(이 클래스 모듈을 여기서 선택했습니다)

이 링크에서 파일을 다운로드할 수 있습니다.

표준 모듈

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

다음 라이브러리로 많은 성공을 거두었습니다.

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

라이브러리에서 사용Scripting.Dictionary개체 및CollectionArrays용이며 상당히 복잡한 json 파일을 구문 분석하는 데 문제가 없었습니다.

직접 json을 구문 분석하는 방법에 대한 자세한 내용은 sc에서 반환된 JScriptTypeInfo 개체와 관련된 문제에 대한 배경을 확인하십시오.평가 통화:

Excel VBA: 구문 분석된 JSON 개체 루프

마지막으로, 작업에 도움이 되는 수업을 위해.XMLHTTPRequest내 프로젝트를 위한 작은 플러그인, VBA-Web:

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

이것이 오래된 질문이라는 것을 알지만, 저는 간단한 상호작용 방법을 만들었습니다.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

사용 예(에서):

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

언급URL : https://stackoverflow.com/questions/16817545/handle-json-object-in-xmlhttp-response-in-excel-vba-code