Access快速开发基础教程
网站公告
·Access专家课堂QQ群号:239158550    ·Access快速开发平台下载地址及教程    ·欢迎加入Access专家课堂微信群!    ·如何快速搜索本站文章|示例|资料    
您的位置: 首页 > 技术文章 > Access数据库-模块/函数/VBA

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

常见问答:

技术分类:

相关资源:

专栏作家

关于我们 | 服务条款 | 在线投稿 | 友情链接 | 网站统计 | 网站帮助