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%syswow64mshta.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即可