1. '以POST方式上传数据、
    2. '--------------------------
    3. 'strUrl            网址
    4. 'strData         内容
    5. 'strHeader     头文件
    6. 'strValue        头文件格式
    7. '===========================
    8. Function f_uploadDataPost(intState As Integer, _
    9.                 strUrl As String, _
    10.                 Optional strData As String, _
    11.                 Optional li_tdiff As Integer, _
    12.                 Optional strHeader As String, _
    13.                 Optional strValue As String) As String
    14.     On Error GoTo err
    15.     Dim http As Object
    16.     Dim I As Long
    17.     Dim lt_stime As Date, lt_ntime As Date
    18.     DoCmd.Hourglass True
    19.     Set http = CreateObject("Microsoft.XMLHTTP")
    20.     http.Open "POST", strUrl, False    '同步抓取
    21.     If strHeader = "" Then strHeader = "CONTENT-TYPE"
    22.     If strValue = "" Then strValue = "application/x-www-form-urlencoded"
    23.     '    Debug.Print strData
    24.     http.setRequestHeader strHeader, strValue     '头文件
    25.     http.Send (strData)  '
    26.     If li_tdiff = 0 Then li_tdiff = 10    '10秒
    27.     lt_stime = Now()    '获取当前时间
    28.     While http.ReadyState <> 4
    29.         DoEvents
    30.         lt_ntime = Now    '获取循环时间
    31.         If DateDiff("s", lt_stime, lt_ntime) > li_tdiff Then    '服务器没有反应
    32.             DoCmd.Hourglass False
    33.             MsgBox "本机与【" & strUrl & "】通讯失败，服务器没有反应！", vbExclamation, "系统提示：" & http.Status
    34.             Set http = Nothing
    35.             Exit Function    '判断超出li_tdiff秒即超时退出过程
    36.         End If
    37.     Wend
    38.     DoCmd.Hourglass False
    39.     I = http.Status
    40.     If I = 200 Then        '定义字符串 json
    41.         f_uploadDataPost = http.responseText
    42.         If InStr(f_uploadDataPost, "Error_Code") > 0 Then
    43.             MsgBox f_uploadDataPost, , "系统提示"
    44.             f_uploadDataPost = ""
    45.         Else
    46.             Debug.Print "交易地址：" & strUrl & vbNewLine & vbNewLine & _
    47.                         "输入json：" & strData & vbNewLine & vbNewLine & _
    48.                         "输出json：" & f_uploadDataPost
    49.         End If
    50.     Else
    51.         intState = 100
    52.         MsgBox "本机与Json服务器通讯失败：" & Chr(13) & "Url【" & strUrl & "】" & Chr(13) & _
    53.                err.Description, vbExclamation, "系统提示 [f_uploadDataPost]" & "_" & http.Status
    54.         f_uploadDataPost = ""
    55.     End If
    56.     Set http = Nothing
    57.     Exit Function
    58. err:
    59.     DoCmd.Hourglass False
    60.     intState = 100
    61.     MsgBox "与【" & strUrl & "】通讯失败：" & Chr(13) & _
    62.            Replace(Nz(err.Description, ""), "The system cannot locate the resource specified", "系统找不到指定的资源"), vbCritical, _
    63.            "系统提示 [f_uploadDataPost]" & intState
    64.     Set http = Nothing
    65. End Function