How to use EXCEL VBA/JSON to scrape tracking info for Various couriers

Question

I am trying to modify VBA code to use a different courier based on the length of the tracking number (e.g. 12 characters = Fedex, 10 characters = DHL, 6 characters = Startrack).

How do I intergrate the If, ElseIf statement taking into account the With, End With statement?

Original JSON converter code: VBA code - connect to webpage and retrieve value

Original 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

On a separate module I tried to get DHL working by changing the VBA to the following

 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

But it threw an error parsing JSON:

Expecting '{' or '['

Expected results are :

if the tracking number it 12 characters, it goes to the Fedex site to get the tracking details
https://www.fedex.com/apps/fedextrack/?action=track&trackingnumber=786215144461

If it is 10 characters it goes to the DHL site to get the tracking details
http://www.dhl.com.au/en/express/tracking.html?AWB=3010931254&brand=DHL

If it is 6 characters it goes to the startrack site to get the tracking info
https://my.startrackcourier.com.au/?type=Number&state=NSW&term=171100

This would then allow me to use the same =GetDeliveryDate(A1) funtion instead of making individual ones for each shipper.

Hello. First things first. You have to understand that HTTP requests/responses and APIs are not a "one-size-fits-all" type of thing. Different websites offer different ways to download data. The format of the response is also different. The JSON has a different structure and so on. You can't just change the URLs and expect it to work across websites. I suggest you research it a bit more thoroughly. — Stavros Jon, Jun 20 '19 at 08:27

QHarr · Accepted Answer · 2019-06-21T05:23:27.333

First off there are quite a few caveats with this.

There are dedicated APIs for all 3 which should be first choice where free but these required set-up so I am not covering those here. For example, with dhl you need to register an app and sign up for the tracking APIs Unified and Global and that needs to be processed. Furthermore, you are basing your test on the length of the tracking id but some cases may require additional info, for example, with StarTrack there are type and state parameters to consider.

With the above in mind, you know you want to test the length of the id, the result of which will determine the courier. We can logically assume that the response is not going to be the same so we could set up branched code, based on length, that calls different functions which handle the tracking request and parsing of response; including failures/items not delivered.

Note: This type of code lends itself nicely to class based coding which if all 3 were API calls I would definitely do. You could implement some nice interfaces to.

That aside, here is a way with the currently available, to me, endpoints. There are some additional notes within code.

I include an initial test sub just so you can test the running of all 3 types.

Set-up requirements:

The following references are required (VBE > Tools > References):

Microsoft HTML Object Library
Microsoft Scripting Runtime

Additionally, you need a standard module named JsonConverter which has the code downloaded from jsonconverter.bas in it.

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

Just got in to give this a try (it is 06:50 here) and it works!!!! You are awesome and I have no idea how I can thank you enough or how you did this so quickly. I changed the date to format to dd-mm-yyyy as I am the same format as you. Where the tracking details have expired, it gives me #VALUE!, is there a way I can make that blank instead? — deaddingo, Jun 20 '19 at 20:54
I may update for APIs if I get access but would need to read the documentation. — QHarr, Jun 20 '19 at 20:55

Armin · Answer 2 · 2022-07-22T07:34:17.870

I have tried your code and respect your recommendations:

Activate reference "Microsoft HTML Object Library"
Activvate reference "Microsoft Scripting Runtime"
Import a module from "jsonconverter.bas"
Create an account on https://developer.dhl/ and add API Shipping Tracking Unified (wait for approved status)

JsonString was wrong with .Open "GET", "http://www.dhl.com.au/shipmentTracking?AWB=" & id & "&countryCode=au&languageCode=en&_=", False

I have read into the doc that the URL needs to be like this:

.Open "GET", "https://api-eu.dhl.com/track/shipments?trackingNumber=" & id, False

This is better but into JsonString, I can have only the city and no other data.

Moreover, I think this is needed to indicate the DHL-API-KEY so I have tried this format :

.setRequestHeader "DHL-API-Key", "REPLACE_KEY_VALUE"

But same result !

Do you have some ideas ?

Greetings

PS : With PowerShell script, It works !

$headers=@{}
$headers.Add("DHL-API-Key", "REPLACE_KEY_VALUE")
$response = Invoke-WebRequest -Uri 'https://api-eu.dhl.com/track/shipments?trackingNumber=SOME_STRING_VALUE' -Method GET -Headers $headers

This does not really answer the question. If you have a different question, you can ask it by clicking [Ask Question](https://stackoverflow.com/questions/ask). To get notified when this question gets new answers, you can [follow this question](https://meta.stackexchange.com/q/345661). Once you have enough [reputation](https://stackoverflow.com/help/whats-reputation), you can also [add a bounty](https://stackoverflow.com/help/privileges/set-bounties) to draw more attention to this question. - [From Review](/review/late-answers/32303798) — Ike, Jul 23 '22 at 20:34

How to use EXCEL VBA/JSON to scrape tracking info for Various couriers

2 Answers2