VB中Http请求测试

最近帮助公司维护一个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请求