如何使用 EXCEL VBA/JSON 抓取各种快递员的跟踪信息

Question

我正在尝试修改 VBA 代码以根据跟踪号的长度使用不同的快递公司（例如，12 个字符 = Fedex，10 个字符 = DHL，6 个字符 = Startrack）。

如何在考虑 With、End With 语句的情况下集成 If、ElseIf 语句？

原始 JSON 转换器代码：VBA code - connect to webpage and retrieve value

原始 VBA

Option Explicit
Public Sub test()
   Debug.Print GetDeliveryDate(727517426234#)
End Sub


Public Function GetDeliveryDate(ByVal id As Double) As Date
    Dim s As String, body As String
    body = "data={""TrackPackagesRequest"":{""appType"":""WTRK"",""appDeviceType"":""DESKTOP"",""supportHTML"":true,""supportCurrentLocation"":true,""uniqueKey"":"""",""processingParameters"":.{},""trackingInfoList"":[{""trackNumberInfo"":{""trackingNumber"":" & Chr$(34) & CStr(id) & Chr$(34) & ",""trackingQualifier"":"""",""trackingCarrier"":""""}}]}}"
    body = body & "&action=trackpackages&locale=en_US&version=1&format=json"

    With CreateObject("MSXML2.XMLHTTP")
        .Open "POST", "https://www.fedex.com/trackingCal/track", False
        .setRequestHeader "Referer", "https://www.fedex.com/apps/fedextrack/?tracknumbers=" & CStr(id)
        .setRequestHeader "User-Agent", "Mozilla/5.0"
        .setRequestHeader "X-Requested-With", "XMLHttpRequest"
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded; charset=UTF-8"
        .send body
        s = .responseText
    End With
    GetDeliveryDate = Split(Replace$(Split(Split(s, """actDeliveryDt"":""")(1), Chr$(34))(0), "\u002d", "-"), "T")(0)
End Function

在一个单独的模块上，我尝试通过将 VBA 更改为以下内容来使 DHL 正常工作

 Public Function GetDHLDeliveryDate(ByVal id As Double) As Date
    Dim json As Object, body As String  '<  VBE > Tools > References > Microsoft Scripting Runtime
    body = "data={""TrackPackagesRequest"":{""appType"":""WTRK"",""appDeviceType"":""DESKTOP"",""supportHTML"":true,""supportCurrentLocation"":true,""uniqueKey"":"""",""processingParameters"":{},""trackingInfoList"":[{""trackNumberInfo"":{""trackingNumber"":" & Chr$(34) & CStr(id) & Chr$(34) & ",""trackingQualifier"":"""",""trackingCarrier"":""""}}]}}"
    body = body & "&action=trackpackages&locale=en_AU&version=1&format=json"

    With CreateObject("MSXML2.XMLHTTP")
        .Open "POST", "https://api.dhlglobalmail.com", False
        .setRequestHeader "Referer", "http://www.dhl.com.au/en/express/tracking.html?AWB=" & CStr(id)
        .setRequestHeader "User-Agent", "Mozilla/5.0"
        .setRequestHeader "X-Requested-With", "XMLHttpRequest"
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded; charset=UTF-8"
        .send body
        Set json = JSONConverter.ParseJson(.responseText)
    End With
    GetDHLDeliveryDate = json("TrackPackagesResponse")("packageList")(1)("displayActDeliveryDt")
End Function

但它在解析 JSON 时抛出了错误：

期待 '{' 或 '['

预期结果是：

如果追踪号码为 12 个字符，则前往 Fedex 网站获取追踪详情
https://www.fedex.com/apps/fedextrack/?action=track&trackingnumber=786215144461

如果是 10 个字符，它会转到 DHL 站点以获取跟踪详细信息
http://www.dhl.com.au/en/express/tracking.html?AWB=3010931254&brand=DHL

如果是 6 个字符，它会去 starttrack 站点获取跟踪信息
https://my.startrackcourier.com.au/?type=Number&state=NSW&term=171100

这将允许我使用相同的=GetDeliveryDate(A1) 功能，而不是为每个托运人制作单独的功能。

Answer 1

首先有很多注意事项。

所有 3 个 API 都有专用的 API，它们应该是免费的首选，但这些需要设置，所以我不在这里介绍这些。例如，使用 dhl，您需要注册一个应用程序并注册跟踪 API 统一和全局，这需要进行处理。此外，您的测试基于跟踪 id 的长度，但在某些情况下可能需要其他信息，例如，使用 StarTrack 时需要考虑类型和状态参数。

考虑到以上，你知道你要测试id的长度，其结果将决定快递。我们可以在逻辑上假设响应不会相同，因此我们可以根据长度设置分支代码，调用不同的函数来处理跟踪请求和解析响应；包括故障/未交付的项目。

注意：这种类型的代码非常适合基于类的编码，如果所有 3 个都是 API 调用，我肯定会这样做。你可以实现一些不错的接口。

除此之外，这是一种对我来说当前可用的端点的方法。代码中有一些额外的注释。

我包含一个初始测试子，以便您可以测试所有 3 种类型的运行。

---

设置要求：

需要以下参考资料（VBE > 工具 > 参考资料）：

1. Microsoft HTML 对象库
2. Microsoft 脚本运行时

此外，您需要一个名为 JsonConverter 的标准模块，其中包含从jsonconverter.bas 下载的代码。

---

VBA：

Option Explicit
Public Sub test()
    Dim trackingId As Variant
    For Each trackingId In Array("3010931254", "727517426234", "171100")
        Select Case Len(trackingId)
        Case 6
            Debug.Print GetStarTrackDeliveryDate(trackingId)
        Case 10
            Debug.Print GetDhlDeliveryDate(trackingId)
        Case 12
            Debug.Print GetFedexDeliveryDate(trackingId)
        End Select
    Next
End Sub

Public Sub DeliveryInfoByCouriers()
    Dim trackingId As String
    trackingId = "3010931254"  '"727517426234" , "171100"  '' <== Activesheet.cells(1,1).value

    Select Case Len(trackingId)
    Case 6
        Debug.Print GetStarTrackDeliveryDate(trackingId)
    Case 10
        Debug.Print GetDhlDeliveryDate(trackingId)
    Case 12
        Debug.Print GetFedexDeliveryDate(trackingId)
    End Select
End Sub

Public Function GetDhlDeliveryDate(ByVal id As String) As String
    Dim json As Object                           '<  VBE > Tools > References > Microsoft Scripting Runtime
    'is an API https://dhlparcel.github.io/api-gtw-docs/ , https://developer.dhl/  which should be preference. Set up an app and register: Shipping Tracking Unified and Global - standard
    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", "http://www.dhl.com.au/shipmentTracking?AWB=" & id & "&countryCode=au&languageCode=en&_=", False
        .setRequestHeader "Referer", "http://www.dhl.com.au/en/express/tracking.html?AWB=3010931254&brand=DHL"
        .setRequestHeader "User-Agent", "Mozilla/5.0"
        .setRequestHeader "X-Requested-With", "XMLHttpRequest"
        .setRequestHeader "Accept", "application/json, text/javascript, */*; q=0.01"
        .send
        Set json = JsonConverter.ParseJson(.responseText)
    End With
    If json("results")(1)("delivery")("status") = "delivered" Then
        GetDhlDeliveryDate = GetDateFromString(json("results")(1)("checkpoints")(1)("date"))
    Else
        GetDhlDeliveryDate = vbNullString        'or other choice of response
    End If
End Function

Public Function GetFedexDeliveryDate(ByVal id As String) As String
    Dim body As String, json As Object
    body = "data={""TrackPackagesRequest"":{""appType"":""WTRK"",""appDeviceType"":""DESKTOP"",""supportHTML"":true,""supportCurrentLocation"":true,""uniqueKey"":"""",""processingParameters"":{},""trackingInfoList"":[{""trackNumberInfo"":{""trackingNumber"":" & Chr$(34) & id & Chr$(34) & ",""trackingQualifier"":"""",""trackingCarrier"":""""}}]}}"
    body = body & "&action=trackpackages&locale=en_US&version=1&format=json"

    With CreateObject("MSXML2.XMLHTTP")
        .Open "POST", "https://www.fedex.com/trackingCal/track", False
        .setRequestHeader "Referer", "https://www.fedex.com/apps/fedextrack/?tracknumbers=" & id
        .setRequestHeader "User-Agent", "Mozilla/5.0"
        .setRequestHeader "X-Requested-With", "XMLHttpRequest"
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded; charset=UTF-8"
        .send body
        Set json = JsonConverter.ParseJson(.responseText)
    End With
    GetFedexDeliveryDate = Format$(json("TrackPackagesResponse")("packageList")(1)("displayActDeliveryDt"), "yyyy-mm-dd")
End Function

Public Function GetStarTrackDeliveryDate(ByVal id As String) As String
    'Note there is an API https://docs.aftership.com/star-track-tracking-api but currently can't sign-up
    'Note request url include params for type and state which should probably be passed in function signature which means you would need
    ' additional logic to handle this in original call
    'Required reference to Microsoft HTML Object Library
    Dim html As HTMLDocument, dateString As String
    Set html = New HTMLDocument

    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", "https://my.startrackcourier.com.au/?type=Number&state=NSW&term=" & id, False
        .send
        html.body.innerHTML = .responseText
        If InStr(html.querySelector(".CountdownStatus").innerText, "Delivered to") > 0 Then
            dateString = html.querySelector(".CountdownStatus ~ span + span").innerText
            GetStarTrackDeliveryDate = Format$(CDate(dateString), "yyyy-mm-dd")
        Else
            GetStarTrackDeliveryDate = vbNullString
        End If
    End With
End Function

Public Function GetDateFromString(ByVal dateString As String) As String
    'desired output format yyyy-mm-dd
    Dim arr() As String, monthDay() As String, iYear As Long, iMonth As Long
    arr = Split(Trim$(dateString), ",")
    monthDay = Split(Trim$(arr(1)), Chr$(32))
    iYear = arr(2)
    iMonth = Month(DateValue("01 " & monthDay(0) & Chr$(32) & CStr(iYear)))
    GetDateFromString = Join(Array(CStr(iYear), CStr(Format$(iMonth, "00")), Format$(monthDay(1), "00")), "-")
End Function