I am trying to track couriers in excel using VBA JSON, as I am new to this field couldn't be able to make perfect code, I found this vba 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/
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