最近帮助公司维护一个VB的项目,需要用到Http请求与Java服务进行通信,这里记录下VB端的实现和代码。
1.1页面
1.2代码
gitLab地址:https://gitlab.com/982837387/vbhttpdemo
'POST发送
Private Sub button1_Click()
Dim str As String
str = Text3.Text
Dim JsonStr As String
JsonStr = Text2.Text
MsgBox "Input JSON string: " & JsonStr
'发送http post请求
Dim responseStr As String
responseStr = HttpPOST(str, JsonStr)
'文本框赋值
Text1.Text = responseStr
End Sub
'GET发送
Private Sub button2_Click()
Dim str As String
str = Text4.Text
Dim JsonStr As String
JsonStr = Text2.Text
Dim accessToken As String
Dim api As Boolean
accessToken = JSONParse("accessToken", JsonStr)
api = JSONParse("api", JsonStr)
'发送http post请求
Dim responseStr As String
responseStr = HttpGET(str, accessToken, api)
'文本框赋值
Text1.Text = responseStr
End Sub
'POST请求
'函数返回值是返回信息
'Url:发送的Url地址
'PostMsg:要发送的数据
Function HttpPOST(URL As String, PostMsg As String) As String
On Error GoTo er
Dim XMLHTTP As Object
Set XMLHTTP = CreateObject("Msxml2.XMLHTTP")
If Not IsObject(XMLHTTP) Then
Set XMLHTTP = CreateObject("Microsoft.XMLHTTP")
If Not IsObject(XMLHTTP) Then Exit Function
End If
'' 同步接收数据
XMLHTTP.Open "POST", URL, False
XMLHTTP.SetRequestHeader "CONTENT-TYPE", "application/json"
XMLHTTP.Send (PostMsg)
Do While XMLHTTP.ReadyState <> 4
DoEvents
Loop
If XMLHTTP.Status = 200 Then
HttpPOST = XMLHTTP.ResponseText
Else
HttpPOST = ""
End If
Exit Function
er:
MsgBox "发送POST请求失败!", , "提示"
End Function
'GET请求
Function HttpGET(URL As String, accessToken As String, api As Boolean) As String
On Error GoTo er
Dim XMLHTTP As Object
Set XMLHTTP = CreateObject("Msxml2.XMLHTTP")
If Not IsObject(XMLHTTP) Then
Set XMLHTTP = CreateObject("Microsoft.XMLHTTP")
If Not IsObject(XMLHTTP) Then Exit Function
End If
'' 同步接收数据
XMLHTTP.Open "GET", URL, False
XMLHTTP.SetRequestHeader "accessToken", accessToken
XMLHTTP.SetRequestHeader "api", api
XMLHTTP.SetRequestHeader "CONTENT-TYPE", "application/json"
XMLHTTP.Send
Do While XMLHTTP.ReadyState <> 4
DoEvents
Loop
If XMLHTTP.Status = 200 Then
HttpGET = XMLHTTP.ResponseText
Else
HttpGET = ""
End If
Exit Function
er:
MsgBox "发送GET请求失败!", , "提示"
End Function
'方法一
Public Function POST(ByVal URL As String, ByVal JSONData As String) As String
Dim HTTP As Object
Set HTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
HTTP.Option(6) = False
HTTP.Option(4) = 13056
HTTP.Open "POST", URL
HTTP.SetRequestHeader "Content-Type", "application/json"
HTTP.SetRequestHeader "Content-Length", LenB(StrConv(JSONData, vbFromUnicode))
HTTP.Send JSONData
POST = HTTP.ResponseText
Set HTTP = Nothing
End Function
Public Function JSONParse(ByVal JSONPath As String, ByVal JSONString As String) As Variant
Dim JSON As Object
Set JSON = CreateObject("MSScriptControl.ScriptControl")
JSON.language = "JScript"
JSONParse = JSON.Eval("JSON=" & JSONString & ";JSON." & JSONPath & ";")
Set JSON = Nothing
End Function
Private Sub Command1_Click()
'文本框赋值
Text1.Text = ""
End Sub
2.测试结果
post请求
get请求