VBA以POST方式上传数据

时　间:2022-01-19 17:25:20
作　者:AngelHis   ID：20576  城市：沈阳
摘　要:VBA以POST方式上传数据。
正　文:

'=========================
'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群 (群号:54525238) 　　　　　　Access源码网店