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

时间：2019-06-20 05:44:49

标签： json excel vba web-scraping

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

我如何综合考虑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个字符，它将进入星轨站点以获取跟踪信息
https://my.startrackcourier.com.au/?type=Number&state=NSW&term=171100

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

1 个答案:

答案 0 :(得分：1)

首先，有很多注意事项。

所有3种都有专用的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
相关问题
最新问题