vb6 PostMan接口测试 Ajax请求 HttpRequest
网络读卡器介绍：https://item.taobao.com/item.htm?spm=a1z10.5-c.w4002-17663462238.11.21915124bXuNyk&id=17021194999
https://item.taobao.com/item.htm?spm=a1z10.5-c.w4002-17663462238.11.21915124bXuNyk&id=17021194999
Private Declare Function MyMD5 Lib "PayApiFun.dll" (ByVal inputstr As String, ByRef outinf As Any) As IntegerPrivate Declare Function timeGetTime Lib "winmm.dll" () As LongPrivate Sub Command1_Click()Dim outinf(500) As Byteresul = MyMD5(Trim(Text1.Text), VarPtr(outinf(0)))If resul = 0 Then Text4.Text = MidB(StrConv(outinf, vbUnicode), 1, 500)End IfEnd SubPrivate Sub Command2_Click()If Trim(Text2.Text) = "" Then MsgBox "请输入需POST的字符!", vbCritical + vbOKOnly, "提示": Exit SubUrl = Trim(Text10.Text)Text4.Text = Ajax_Post(Url, Trim(Text2.Text), 1)End SubPrivate Sub Command3_Click()If Trim(Text2.Text) = "" Then MsgBox "请输入需POST的字符!", vbCritical + vbOKOnly, "提示": Exit SubUrl = Trim(Text3.Text)Text4.Text = Ajax_Post(Url, Trim(Text2.Text), 1)End SubPrivate Sub Command4_Click()Dim Url As String, Key As Variant, JsonKey As String, timestamp As String, sign As StringDim outinf(500) As ByteText4.Text = ""timestamp = DateDiff("s", "1970-1-1 0:0:0", DateAdd("h", -8, Now)) & Right(timeGetTime, 3)Key = Array("type=" & Trim(Text5.Text), "card=" & Trim(Text6.Text), "operator=" & Trim(Text7.Text), "timestamp=" & timestamp, "key=" & Trim(Text8.Text), "secret=" & Trim(Text9.Text))JsonKey = Join(Key, "&")Text1.Text = JsonKeyresul = MyMD5(JsonKey, VarPtr(outinf(0)))If resul = 0 Then sign = MidB(StrConv(outinf, vbUnicode), 1, 500) Key = Array("type=" & Trim(Text5.Text), "card=" & Trim(Text6.Text), "operator=" & Trim(Text7.Text), "timestamp=" & timestamp, "key=" & Trim(Text8.Text), "sign=" & sign) JsonKey = Join(Key, "&") Text2.Text = JsonKey Url = Trim(Text3.Text) If Option1.Value = True Then Text4.Text = Ajax_Post(Url, Trim(Text2.Text), 1) Else Text4.Text = Win_HttpRequest_Post(Url, JsonKey, 1) End IfEnd If End SubPrivate Sub Command5_Click()Dim Url As String, Key As Variant, JsonKey As String, timestamp As String, sign As StringDim outinf(500) As ByteText4.Text = ""timestamp = DateDiff("s", "1970-1-1 0:0:0", DateAdd("h", -8, Now)) & Right(timeGetTime, 3)Key = Array("type=" & Trim(Text5.Text), "formerCard=" & Trim(Text11.Text), "newCard=" & Trim(Text12.Text), "operator=" & Trim(Text7.Text), "timestamp=" & timestamp, "key=" & Trim(Text8.Text), "secret=" & Trim(Text9.Text))JsonKey = Join(Key, "&")Text1.Text = JsonKeyresul = MyMD5(JsonKey, VarPtr(outinf(0)))If resul = 0 Then sign = MidB(StrConv(outinf, vbUnicode), 1, 500) Key = Array("type=" & Trim(Text5.Text), "formerCard=" & Trim(Text11.Text), "newCard=" & Trim(Text12.Text), "operator=" & Trim(Text7.Text), "timestamp=" & timestamp, "key=" & Trim(Text8.Text), "sign=" & sign) JsonKey = Join(Key, "&") Text2.Text = JsonKey Url = Trim(Text10.Text) If Option1.Value = True Then Text4.Text = Ajax_Post(Url, Trim(Text2.Text), 1) Else Text4.Text = Win_HttpRequest_Post(Url, JsonKey, 1) End IfEnd IfEnd SubPrivate Sub Command6_Click()Dim Url As String, Key As Variant, JsonKey As String, timestamp As String, sign As StringDim outinf(500) As ByteText4.Text = ""If Trim(Text14.Text) = "" Then MsgBox "请输入唯一的msgId", vbCritical + vbOKOnly, "提示" Text14.SetFocus Exit SubEnd Iftimestamp = DateDiff("s", "1970-1-1 0:0:0", DateAdd("h", -8, Now)) & Right(timeGetTime, 3)Key = Array("msgId=" & Trim(Text14.Text), "ic=" & Trim(Text6.Text), "place=" & Trim(Text15.Text), "price=" & Trim(Text16.Text), "type=" & Trim(Text5.Text), "date=" & Format(Now, "YYYY-MM-DD"), "time=" & Format(Now, "HH:MM:SS"), "timestamp=" & timestamp, "key=" & Trim(Text8.Text), "secret=" & Trim(Text9.Text))JsonKey = Join(Key, "&")Text1.Text = JsonKeyresul = MyMD5(JsonKey, VarPtr(outinf(0)))If resul = 0 Then sign = MidB(StrConv(outinf, vbUnicode), 1, 500) Key = Array("msgId=" & Trim(Text14.Text), "ic=" & Trim(Text6.Text), "place=" & Trim(Text15.Text), "price=" & Trim(Text16.Text), "type=" & Trim(Text5.Text), "date=" & Format(Now, "YYYY-MM-DD"), "time=" & Format(Now, "HH:MM:SS"), "timestamp=" & timestamp, "key=" & Trim(Text8.Text), "sign=" & sign) JsonKey = Join(Key, "&") Text2.Text = JsonKey Url = Trim(Text13.Text) Text4.Text = Win_HttpRequest_Post(Url, JsonKey, 1)End IfEnd SubPublic Function Win_HttpRequest_Post(ByVal StrUrl As String, ByVal StrData As String, Optional ByVal Index As Long) As VariantDim aHttpRequest As WinHttp.WinHttpRequestDim sUrl As StringDim sMethod As StringDim sBody As StringDim sResponse As StringDim S As String, B() As Byte On Error GoTo MyError:sUrl = StrUrlsBody = StrDatasMethod = "POST"Set aHttpRequest = CreateObject("WinHttp.WinHttpRequest.5.1")aHttpRequest.Open sMethod, sUrl, TrueaHttpRequest.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = &H3300aHttpRequest.SetRequestHeader "Content-Length", Len(sBody)aHttpRequest.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"aHttpRequest.SetRequestHeader "Connection", "Keep-Alive"aHttpRequest.Send sBodyaHttpRequest.WaitForResponseSelect Case Index Case 1: S = aHttpRequest.ResponseText: Win_HttpRequest_Post = S '返回字符串 Case 2: B = aHttpRequest.ResponseBody: Win_HttpRequest_Post = B '返回二进制 Case 3: S = BytesToStr(aHttpRequest.ResponseBody): Win_HttpRequest_Post = S '二进制转字符串[直接返回字串出现乱码时尝试] Case Else: Win_HttpRequest_Post = vbNullString '无效的返回End Select Set aHttpRequest = NothingExit FunctionMyError: Win_HttpRequest_Post = "HttpRequest请求异常，错误编号：" & Err.Number & " ，错误描述：" & Err.Description '出错返回空End FunctionPublic Function Ajax_Post(ByVal StrUrl As String, Optional ByVal StrData As String, Optional ByVal Index As Long) As Variant On Error GoTo MyError: Dim Object As Object, S As String, B() As Byte Set Object = CreateObject("Microsoft.XMLHTTP") Object.Open "POST", StrUrl, True Object.SetRequestHeader "Content-Length", Len(Ajax_Post) Object.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded" Object.Send (StrData) Do Until Object.readyState = 4 DoEvents Loop Select Case Index Case 1: S = Object.ResponseText: Ajax_Post = S '返回字符串 Case 2: B = Object.ResponseBody: Ajax_Post = B '返回二进制 Case 3: S = BytesToStr(Object.ResponseBody): Ajax_Post = S '二进制转字符串[直接返回字串出现乱码时尝试] Case Else: Ajax_Post = vbNullString '无效的返回 End Select Set Object = Nothing '释放空间 Exit FunctionMyError: Ajax_Post = "HttpRequest请求异常，错误编号：" & Err.Number & " ，错误描述：" & Err.Description '出错返回空End FunctionFunction BytesToStr(ByVal vIn) As String Dim strReturn As String, ThisCharCode As String, NextCharCode As String, I As Long For I = 1 To LenB(vIn) ThisCharCode = AscB(MidB(vIn, I, 1)) If ThisCharCode < &H80 Then strReturn = strReturn & Chr(ThisCharCode) Else NextCharCode = AscB(MidB(vIn, I + 1, 1)) strReturn = strReturn & Chr(CLng(ThisCharCode) * &H100 + CInt(NextCharCode)) I = I + 1 End If Next BytesToStr = strReturnEnd Function
