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

时间：2021-06-13 10:16:53

作者：iamlasong

1、接口说明

通过互联网訪问，运单跟踪信息查询接口基于HTTP协议开发，接口为RESTFul风格的Web Service，信息交互过程为用户按我方提供的web service地址进行调用，我方接到调用请求后，为用户返回JSON格式组织的数据信息。用户根据约定的接口规范对数据进行解析。

接口调用为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、查询界面

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

3、查询结果

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

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要换成真实地址和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



相关文章