'=========================
'VBA以POST方式上传数据、
'--------------------------
'strUrl 网址
'strData 内容
'strHeader 头文件
'strValue 头文件格式
'===========================
Function f_uploadDataPost(intState As Integer, _
strUrl As String, _
Optional strData As String, _
Optional li_tdiff As Integer, _
Optional strHeader As String, _
Optional strValue As String) As String
On Error GoTo err
Dim http As Object
Dim I As Long
Dim lt_stime As Date, lt_ntime As Date
DoCmd.Hourglass True
Set http = CreateObject("Microsoft.XMLHTTP")
http.Open "POST", strUrl, False '同步抓取
If strHeader = "" Then strHeader = "CONTENT-TYPE"
If strValue = "" Then strValue = "application/x-www-form-urlencoded"
' Debug.Print strData
http.setRequestHeader strHeader, strValue '头文件
http.Send (strData) '
If li_tdiff = 0 Then li_tdiff = 10 '10秒
lt_stime = Now() '获取当前时间
While http.ReadyState <> 4
DoEvents
lt_ntime = Now '获取循环时间
If DateDiff("s", lt_stime, lt_ntime) > li_tdiff Then '服务器没有反应
DoCmd.Hourglass False
MsgBox "本机与【" & strUrl & "】通讯失败,服务器没有反应!", vbExclamation, "系统提示:" & http.Status
Set http = Nothing
Exit Function '判断超出li_tdiff秒即超时退出过程
End If
Wend
DoCmd.Hourglass False
I = http.Status
If I = 200 Then '定义字符串 json
f_uploadDataPost = http.responseText
If InStr(f_uploadDataPost, "Error_Code") > 0 Then
MsgBox f_uploadDataPost, , "系统提示"
f_uploadDataPost = ""
Else
Debug.Print "交易地址:" & strUrl & vbNewLine & vbNewLine & _
"输入json:" & strData & vbNewLine & vbNewLine & _
"输出json:" & f_uploadDataPost
End If
Else
intState = 100
MsgBox "本机与Json服务器通讯失败:" & Chr(13) & "Url【" & strUrl & "】" & Chr(13) & _
err.Description, vbExclamation, "系统提示 [f_uploadDataPost]" & "_" & http.Status
f_uploadDataPost = ""
End If
Set http = Nothing
Exit Function
err:
DoCmd.Hourglass False
intState = 100
MsgBox "与【" & strUrl & "】通讯失败:" & Chr(13) & _
Replace(Nz(err.Description, ""), "The system cannot locate the resource specified", "系统找不到指定的资源"), vbCritical, _
"系统提示 [f_uploadDataPost]" & intState
Set http = Nothing
End Function
Access软件网交流QQ群(群号:198465573) |