VBA访问WebAPI,EXCEL

关键字：EXCEL，K3Cloud WEBAPI，VBA，数据集成。

基础要求：1、了解第三方工具如何进行K3 Cloud WEBAPI调用。2、了解VBA。

适用版本：EXCEL2003及以后版本。K3cloud 版本7

示例简介：此处提供一个Excel VBA 访问Webapi并返回的示例。

    本代码未指定登陆地址、数据中心代码，用户名，密码等 参数，需手工制定后才能执行。

方式1: 新建一个excel文件，按下alt+f11，粘贴如下内容，将const 部分的变量替换成你的配置，按下F5即可执行。

方式2:示例文件xlsm是带宏的excel文件，打开后允许宏，按下alt+f11，将const 部分的变量替换成你的配置，按下F5即可执行。

以下为代码

'--------------------------------------------------------------------
'Create by Mellon Lee,2019.02.18
'EXCEL VBA -K3Cloud WebAPI Sample
'58644825##qq.com
'--------------------------------------------------------------------

Const URLPrix = "https://具体地址/k3cloud/"   '地址以k3cloud/结尾,http部分注意是https还是http
Const dbc = "你的数据中心编号"     '数据中心
Const UserName = "你的用户名"    '用户名
Const pwd_ = "你的密码"    '密码

'--------------------------------------------------------------------
' 入口函数,登录并执行一个查询，并将返回结果放在新的Excel工作表中
'--------------------------------------------------------------------
Public Sub K3CLOUD_TST()

Dim objxml As Object
Set objxml = CreateObject("MSXML2.XMLHTTP") '创建MSXML2.XMLHTTP 对象 执行http访问
COOKIE = P1_loginAndGetCookie() '登录验证并返回cookie
If COOKIE = "" Then
MsgBox "K3访问错误503，用户密码不正确或数据服务不可访问"
Exit Sub
End If

If COOKIE <> "" Then
'"Cookie展示,执行其他WebApi访问
'这里示例，访问基础资料的物料，获取最多10条物料编码和名称
jsonMaterial = P2_makeQueryJson( _
"BD_MATERIAL", _
"FNUMBER,FNAME", _
" FDocumentStatus='C' ", _
"0", _
"10", _
"")
Dim mData()
P1_ExecuteBillQuery URLPrix, objxml, COOKIE, jsonMaterial, mData '执行查询操作，返回mData数组
P1_clearTheSheet "mData", "FNUMBER,FNAME", mData '将mData 结果放到名称为mData的excel工作表中

End If
Set objxml = Nothing

End Sub

'--------------------------------------------------------------------
' p1: 登录验证并返回cookie
'--------------------------------------------------------------------

Private Function P1_loginAndGetCookie() As String
Dim strResponse As String
Dim strHeaders As String
Dim objxml As Object

URL = URLPrix + "Kingdee.BOS.WebApi.ServicesStub.AuthService.ValidateUser.common.kdsvc"
dataPA = P2_makeLoginJson() '制作登录验证JSON

Set objxml = CreateObject("MSXML2.XMLHTTP")
objxml.Open "POST", URL, False ' POST方法
objxml.setrequestheader "Content-Type", "application/json; charset=UTF-8"
objxml.Send dataPA '发送body

Do While objxml.readyState <> 4 '同步方式，等待远程返回
DoEvents
Loop

strResponse = objxml.responsetext  '获取WEBAPI返回结果
strHeaders = objxml.GetAllResponseHeaders '获取WEBAPI返回Headers

If strResponse = "服务不可用。" Then
'个别情况下，WEBAPI服务不可用直接返回汉字
P1_loginAndGetCookie = ""
'本函数直接返回空串并跳出
Exit Function
End If
'以下利用调用html对象的JAVASCRIPT， 解析返回值得JSON
Set oDom = CreateObject("htmlfile")
Set oWindow = oDom.parentWindow
oWindow.execScript "var rslt=" & strResponse
'返回串中，如果出现的500

x = Trim(oWindow.rslt.LoginResultType)

If x = "1" Then
COOKIE = P3_getResponseHeader(strHeaders, "Set-Cookie") '利用Headers获取Cookie
P1_loginAndGetCookie = COOKIE
Else
P1_loginAndGetCookie = ""
End If

End Function


'--------------------------------------------------------------------
' p2: 制作登录验证JSON
'--------------------------------------------------------------------
Private Function P2_makeLoginJson()
P2_makeLoginJson = "{""parameters"": [""" + dbc + """ ,""" + UserName + """,""" + pwd_ + """," + "2052]}"
'返回JSON
End Function

Public Function P2_makeQueryJson(FormId, FieldKeys, FilterString, StartRow, Limit, OrderString)
'这里拼凑P1_ExecuteBillQuery用的JSON
json = "{""parameters"": [{"
json = json & """FormId"": """ & FormId & ""","
json = json & """FieldKeys"": """ & FieldKeys & """"
If Len(Trim(FilterString)) > 0 Then json = json & ",""FilterString"":""" & FilterString & """"
If Len(Trim(StartRow)) > 0 Then json = json & ",""StartRow"": " & StartRow
If Len(Trim(Limit)) > 0 Then json = json & ",""Limit"": " & Limit
If Len(Trim(OrderString)) > 0 Then json = json & ",""OrderString"": """ & OrderString & """"
json = json & "}]}"
P2_makeQueryJson = json

End Function



'--------------------------------------------------------------------
' p3: 通过字符串匹配，解析ResponseHeaders，获取cookie，并编写成串，以供后续使用
'--------------------------------------------------------------------

Private Function P3_getResponseHeader(ResponseHeaders, Header)
Dim hs, h
Dim fs
Dim rs As String
Dim t As String
hs = Split(ResponseHeaders, vbCrLf)
rs = "["
For Each h In hs
If Len(h) > 0 Then
fs = Split(h, ": ")
If StrComp(fs(0), Header, vbTextCompare) = 0 Then
t = fs(1)
rs = rs + """" + t + ""","
End If
End If
Next

If Len(rs) > 1 Then
P3_getResponseHeader = Left(rs, Len(rs) - 1) + "]"
Else
P3_getResponseHeader = ""
End If

End Function

'--------------------------------------------------------------------
'示例： 利用P1_ExecuteBillQuery，访问WEBAPI并取回结果
'--------------------------------------------------------------------
Public Sub P1_ExecuteBillQuery(URL_Prix, ByRef objxml, COOKIE, json, ByRef sData) '执行查询

URL = URL_Prix + "Kingdee.BOS.WebApi.ServicesStub.DynamicFormService.ExecuteBillQuery.common.kdsvc"
objxml.Open "POST", URL, False
objxml.setrequestheader "Content-Type", "application/json; charset=UTF-8"
objxml.setrequestheader "Cookie", COOKIE
objxml.Send json
Debug.Print json
Do While objxml.readyState <> 4
DoEvents
Loop

strResponse = objxml.responsetext

Debug.Print strResponse

If strResponse = "服务不可用。" Then
'服务不可用 ,直接跳出执行
ReDim sData(0)
Exit Sub
End If

If LCase(Left(strResponse, Len("response_error"))) = "response_error" Then
'拼凑的JSON有问题是，或者url等存在问题 ,直接跳出执行
ReDim sData(0)
Exit Sub
End If

'以下解析正确的返回[[编码,名称],[编码,名称],[编码,名称]......] 或[]到VBA的数组中，
Set oDom = CreateObject("htmlfile")
Set oWindow = oDom.parentWindow
oDom.write "