用VB6来完成POST提交data字串

Option Explicit
Public Declare Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long
Private Const CP_UTF8 = 65001
Public Const BAIDU_APP_KEY = "你的APP KEY" '在百度申请后得到

Public Const BAIDU_SECRET_KEY = "你的SECRET KEY" '在百度申请后得到
Public Function strCut(strContent, strStart, strEnd) As String '文件截取函数
Dim strHTML, s1, s2 As String
strHTML = strContent
On Error Resume Next
s1 = InStr(strHTML, strStart) + Len(strStart)
s2 = InStr(s1, strHTML, strEnd)
strCut = Mid(strHTML, s1, s2 - s1)
End Function
Private Function GetToken() As String
Dim HTTP As Object
Dim URL As String
Dim Buff() As Byte
On Error GoTo wrong
Set HTTP = CreateObject("WinHttp.WinHttpRequest.5.1") '创建WinHttpRequest对象
URL = "https://aip." & BAIDU_APP_KEY & "&client_secret=" & BAIDU_SECRET_KEY & "&"
With HTTP
.setTimeouts 50000, 50000, 50000, 50000 '设置超时时间
.Open "GET", URL, True
.send
.waitForResponse
If .Status = 200 Then '成功获取页面
Buff = .ResponseBody
GetToken = strCut(Utf8ToUnicode(Buff), "access_token"":""", """,""scope")
Else
MsgBox "Http错误代码:" & .Status, vbInformation, "提示"
End If
End With
Set HTTP = Nothing
Exit Function
wrong:
MsgBox "错误原因:" & Err.Description & "", vbInformation, "提示"
Set HTTP = Nothing
End Function
Private Function Utf8ToUnicode(ByRef Utf() As Byte) As String 'utf-8解码
Dim lRet As Long
Dim lLength As Long
Dim lBufferSize As Long
lLength = UBound(Utf) - LBound(Utf) + 1
If lLength <= 0 Then Exit Function
lBufferSize = lLength * 2
Utf8ToUnicode = String$(lBufferSize, Chr(0))
lRet = MultiByteToWideChar(CP_UTF8, 0, VarPtr(Utf(0)), lLength, StrPtr(Utf8ToUnicode), lBufferSize)
If lRet <> 0 Then
Utf8ToUnicode = Left(Utf8ToUnicode, lRet)
Else
Utf8ToUnicode = ""
End If
End Function
Public Function HttpPOST(ByVal JSONData As String) As String
Dim HTTP As Object
Dim URL As String
Dim Buff() As Byte
URL = "https://aip." & GetToken
Set HTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
With HTTP
.setTimeouts 50000, 50000, 50000, 50000 '设置超时时间
.Option(6) = False
.Option(4) = 13056
.Open "POST", URL
.setRequestHeader "Content-Length", LenB(StrConv(JSONData, vbFromUnicode))
.send JSONData
.waitForResponse
If .Status = 200 Then '成功获取页面
Buff = .ResponseBody
HttpPOST = Utf8ToUnicode(Buff)
End If
End With
Set HTTP = Nothing
End Function