json - Excel VBA/JSON 抓取 UPS 跟踪交付

Question

感谢@QHarr 的帮助和代码，我从 Fedex、DHL 和 Startrack 获得了跟踪信息。我一直在尝试使用他的代码和 UPS tracking Web Service Developer Guide 和 Tracking JSON Developer Guides 来让 UPS 在 Excel 中也能正常工作。 JSON 转换器代码来自这里 https://github.com/VBA-tools/VBA-JSON/blob/master/JsonConverter.bas

我试过的代码如下

Public Function GetUPSDeliveryDate(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_AU&version=1&format=json"

    With CreateObject("MSXML2.XMLHTTP")
        .Open "POST", "http://wwwapps.ups.com/WebTracking", False
        .setRequestHeader "Referer", "https://www.ups.com/track?loc=en_AU&tracknum=" & 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
    GetUPSDeliveryDate = Format$(json("ResponseStatus")("ShipmentType")(1)("DeliveryDate"), "dddd, mmm dd, yyyy")
End Function

我没有在代码中得到任何错误，但是当我使用 =GetUPSDeliveryDate() 函数时，我得到一个#VALUE!响应而不是 2019 年 5 月 7 日的交付日期，所以我猜我有以下错误

    GetUPSDeliveryDate = Format$(json("ResponseStatus")("ShipmentType")(1)("DeliveryDate"), "dddd, mmm dd, yyyy")

我也尝试了以下方法，但没有运气。

    If json("results")(1)("delivery")("status") = "delivered" Then
         GetUPSDeliveryDate = json("results")(1)("checkpoints")(1)("date")
    Else
        GetUPSDeliveryDate = vbNullString  
    End If

UPS 跟踪号示例为 1Z740YX80140148107

任何帮助将不胜感激。

谢谢

Answer 1

以下是模仿这个UPS tracking site .使用的 json 解析器是 jsonconverter.bas:从 here 下载原始代码并添加到名为 jsonConverter 的标准模块中.然后您需要转到 VBE > 工具 > 引用 > 添加对 Microsoft Scripting Runtime 的引用。

Option Explicit

Public Sub test()

    Debug.Print GetUPSDeliveryDate("1Z740YX80140148107")

End Sub
Public Function GetUPSDeliveryDate(ByVal id As String) As String
    Dim body As String, json As Object
    body = "{""Locale"":""en_US"",""TrackingNumber"":[""" & id & """]}"
    With CreateObject("MSXML2.XMLHTTP")
        .Open "POST", "https://www.ups.com/track/api/Track/GetStatus?loc=en_US", False
        .setRequestHeader "Referer", "https://www.ups.com/track?loc=en_US&requester=ST/"
        .setRequestHeader "User-Agent", "Mozilla/5.0"
        .setRequestHeader "DNT", "1"
        .setRequestHeader "Content-Type", "application/json"
        .setRequestHeader "Accept", "application/json, text/plain, */*"
        .send body
        Set json = JsonConverter.ParseJson(.responseText)
    End With
    If json("trackDetails")(1)("packageStatus") = "Delivered" Then
        GetUPSDeliveryDate = json("trackDetails")(1)("deliveredDate")
    Else
        GetUPSDeliveryDate = "Not yet delivered"
    End If
End Function

Tracking Web Service Developer Guide.pdf 包含使用官方跟踪 API 进行设置所需了解的所有内容。