Gérer L'objet JSON dans la réponse XMLHttp dans le Code Excel VBA

j'ai eu beaucoup de succès avec la bibliothèque suivante:

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

La bibliothèque utilise Scripting.Dictionary pour les Objets et Collection pour les tableaux et je n'ai eu aucun problème avec l'analyse des fichiers JSON assez complexes.

pour plus d'informations sur l'analyse de json vous-même, consultez cette question pour plus d'informations sur les problèmes entourant L'objet JScriptTypeInfo renvoyé du sc.Eval appel:

Excel VBA: Parsed JSON Object Loop

Enfin, pour quelques classes pour travailler avec XMLHTTPRequest, un peu de pub pour mon projet, VBA-Web:

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

je sais que c'est une vieille question, mais j'ai créé un simple moyen d'interagir avec Json à partir de requêtes web. Où j'ai enveloppé la requête web.

Disponible ici

vous avez besoin du code suivant comme un class moduleJson

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

exemple D'utilisation (de 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