VBA通过HTTP协议实现邮件轨迹跟踪查询

作者：iamlasong

1、接口说明

通过互联网访问，接口调用为HTTP请求的方式，每一次由用户发起的HTTP请求，需要设置验证信息，具体方法是，在HTTP Header部分增加version及authenticate属性，属性值在联调测试之前由总部提供。

接口调用地址：http:// IP:Port/invoke/path/{mail_num}

接口调用方式：HTTP GET方式，通过HTTP GET发起请求，使用真实邮件号替换{mail_num}

编码格式：UTF-8

接口返回数据格式：

{"traces":[{"acceptTime":"2011-11-2417:55:00","acceptAddress":"上海邮政速递物流长宁经营部","remark":"收寄"},{"acceptTime":"2011-11-2417:59:00","acceptAddress":"上海邮政速递物流长宁经营部","remark":"离开处理中心,发往上海市邮政公司邮政速递局"},{"acceptTime":"2011-11-2423:54:38","acceptAddress":"上海市","remark":"到达处理中心,来自上海邮政速递物流长宁经营部"},{"acceptTime":"2011-11-2500:17:42","acceptAddress":"上海市","remark":"离开处理中心,发往USSFOF"},{"acceptTime":"2011-12-0507:41:00","acceptAddress":"美国 94704","remark":"到达投递局"},{"acceptTime":"2011-12-0511:07:00","acceptAddress":"美国94703","remark":"妥投"}]}

acceptTime表示处理时间

acceptAddress表示处理地点

remark表示处理动作

2、查询界面

3、查询结果

4、程序实现

<pre name="code" class="vb">Dim tt, stime(80), saddr(80), state(80) As String

Public Sub get_data()
    '
    Dim HttpReq As Object
    Dim i, k, kk, row1 As Integer
    
    lineno = [A65536].End(xlUp).Row      '行数
    Range("B2:B" & lineno).ClearContents
    'lineno = ActiveSheet.UsedRange.Rows.Count
    Set HttpReq = CreateObject("MSXML2.XMLHTTP.3.0")
    
    row1 = 2
    maxrow = Sheets("查询结果").UsedRange.Rows.Count
    If maxrow >= 2 Then
        Sheets("查询结果").Range("A2:D" & maxrow).ClearContents
    End If
    For i = 2 To lineno
        mail = Cells(i, 1)
        If mail = "" Then Exit For
        '下面的<span style="font-family: Arial; ">IP:PORT要换成真实地址和端口</span>
        HttpReq.Open "Get", "http:// IP:Port/invoke/path/" & LTrim(mail), False
        '下面的验证属性参数pppppppp1,2换成真实的属性值
        HttpReq.setRequestHeader "Authenticate", "pppppppp1"
        HttpReq.setRequestHeader "Version", "pppppppp2"
        
        HttpReq.send
        'MsgBox HttpReq.getAllResponseHeaders
        'MsgBox HttpReq.responseText
        
        kk = get_trace(HttpReq.responseText)
        Cells(i, 2) = tt
        Sheets("查询结果").Cells(row1, 1) = mail
        For k = 1 To kk
            Sheets("查询结果").Cells(row1, 2) = stime(k)
            Sheets("查询结果").Cells(row1, 3) = saddr(k)
            Sheets("查询结果").Cells(row1, 4) = state(k)
            row1 = row1 + 1
        Next k
        If CInt((lineno - i) / 10) * 10 = lineno - i Then
            Application.StatusBar = "剩余邮件数：" & lineno - i
        End If
    
    Next i
    
    Sheets("查询结果").Activate
    msg = MsgBox("邮件批量查询完毕，共查询" & i - 3 & "个邮件！", vbOKOnly, "ＡＨＥＭＳ：iamlaosong")

End Sub
'函数，从字符串中取出轨迹信息，返回条数
Function get_trace(mystring As String) As Integer
    Dim m1, m2, m3, m4, n, sn As Integer
    Dim buf As String
    
    buf = mystring
    sn = 1
    tt = "0"
    For n = 1 To 80
        m1 = InStr(sn, buf, "acceptTime", vbTextCompare)
        If m1 = 0 Then Exit For
        m2 = InStr(sn, buf, "acceptAddress", vbTextCompare)
        m3 = InStr(sn, buf, "remark", vbTextCompare)
        m4 = InStr(sn, buf, "}", vbTextCompare)
        stime(n) = Mid(buf, m1 + 13, 20)
        saddr(n) = Mid(buf, m2 + 16, m3 - m2 - 19)
        state(n) = Mid(buf, m3 + 9, m4 - m3 - 10)
        sn = m4 + 2
    Next n
    
    If state(n - 1) = "妥投" Then tt = "1"
    get_trace = n - 1
End Function

原文：http://blog.csdn.net/iamlaosong/article/details/37928889