Php接收Vba post例子,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字符串

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:

""", 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即可