VBA 发送 GET/POST 请求并解析 json 数据

1. 发送 GET 请求

'以GET方式上传数据
Function uploadData1(ByVal url As String)
    Dim http
    Set http = CreateObject("Microsoft.XMLHTTP")

    http.Open "GET", url, False
    http.send
    uploadData1 = http.Status
End Function

2. 发送 POST 请求

'以POST方式上传数据
Function uploadData2(ByVal url As String, ByVal data As String)
    Dim http
    Set http = CreateObject("Microsoft.XMLHTTP")
  
    http.Open "POST", url, False
    http.setRequestHeader "CONTENT-TYPE", "application/json"
    http.send (data)  'data为JSON字符串, 评论区有人说需要对data加小括号, 我自己的情况是加不加都可以, 这里姑且加上
    uploadData2 = http.Status
End Function

3. 发送 GET 请求并解析返回的 josn 数据

Function getData(ByVal url As String, sht As Worksheet, ByVal rowNum As Integer, ByVal colNum As Integer)
    Dim http As Object   
    Set http = CreateObject("Microsoft.XMLHTTP")     ' 创建 http 对象以发送请求
    http.Open "GET", url, False                      ' 设置请求地址
    http.setRequestHeader "CONTENT-TYPE", "application/x-www-form-urlencoded"     '设置请求头
    http.send    '发送请求
    If http.Status = 200 Then
        Dim json$                      '定义字符串 json
        json = http.responseText       '获取相应结果      
        '接下来是解析 json
        Set objSC = CreateObject("ScriptControl")
        'Set objSC = CreateObjectx86("MSScriptControl.ScriptControl")   '在64位版Excel中的处理方法
        objSC.Language = "JScript"
        strJSON = "var json=" & json & ";"
        objSC.AddCode (strJSON)       '将 json 由字符串解析为对象
        
        Dim j, k, l
        Dim arr()                               '定义一个数组来接收 json 中的数据
        ReDim arr(1 To rowNum, 1 To colNum)     '可以提高向 Excel 单元格填充数据的效率
        indexArr = ['a','b', ...]       '这个数组表示的是后端返回的数据表的列名组成的列表, 用于在 json 对象中索引每列数据
        On Error GoTo err_handle                '错误处理
        For j = 1 To rowCount
            For k = 1 To colCount
                Dim kk
                kk = "json.obj[" + CStr(j - 1) + "]." + indexArr(k - 1)
                arr(j, k) = objSC.eval(kk)
            Next
            l = l + 1
        Next
      
err_handle:
	If l = "" Then
	Exit Function
Else
    sht.Range(Cells(1, 1), Cells(l, colCount)).Value2 = arr   '将数组填入 Excel 表格
End If
    End If
End Function

需要注意的是, 在64位版Excel中, CreateObject方法不再适用, 此时需要引入下面的代码

Function CreateObjectx86(Optional sProgID, Optional bClose = False)
    Static oWnd As Object
    Dim bRunning As Boolean
    #If Win64 Then
        bRunning = InStr(TypeName(oWnd), "HTMLWindow") > 0
        If bClose Then
            If bRunning Then oWnd.Close
            Exit Function
        End If
        If Not bRunning Then
            Set oWnd = CreateWindow()
            oWnd.execScript "Function CreateObjectx86(sProgID): Set CreateObjectx86 = CreateObject(sProgID): End Function", "VBScript"
        End If
        Set CreateObjectx86 = oWnd.CreateObjectx86(sProgID)
    #Else
        Set CreateObjectx86 = CreateObject("MSScriptControl.ScriptControl")
    #End If
End Function


Function CreateWindow()
    Dim sSignature, oShellWnd, oProc
    On Error Resume Next
    sSignature = Left(CreateObject("Scriptlet.TypeLib").GUID, 38)
    CreateObject("WScript.Shell").Run "%systemroot%\syswow64\mshta.exe about:""about:<head><script>moveTo(-32000,-32000);document.title='x86Host'</script><hta:application showintaskbar=no /><object id='shell' classid='clsid:8856F961-340A-11D0-A96B-00C04FD705A2'><param name=RegisterAsBrowser value=1></object><script>shell.putproperty('" & sSignature & "',document.parentWindow);</script></head>""", 0, False
    Do
        For Each oShellWnd In CreateObject("Shell.Application").Windows
            Set CreateWindow = oShellWnd.GetProperty(sSignature)
            If Err.Number = 0 Then Exit Function
            Err.Clear
        Next
    Loop
End Function

然后将 CreateObject方法改为CreateObjectx86即可

原文链接：https://blog.csdn.net/weixin_42902669/article/details/89308309