(Solved) – Courier Tracking using excel VBA

  • by
(solved)-–-courier-tracking-using-excel-vba

I am trying to track couriers in excel using VBA JSON, as I am new to this field couldn’t be able to crack it out as code I found somewhere online and I tried to debug it for my current task. Any help in sorting this code out would be appreciated.
The excel format I am using is to track from this web https://www.courierpost.co.nz/
enter image description here

VBA code is mentioned here but I couldn’t be able to modify it for my current needs.

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", "https://www.courierpost.co.nz/" & id & "&countryCode=au&languageCode=en&_=", False
        .setRequestHeader "Referer", "https://www.courierpost.co.nz/?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

Leave a Reply

Your email address will not be published. Required fields are marked *