Во-первых, с этим довольно много предостережений.
Существуют специальные API-интерфейсы для всех 3, которые должны быть первыми, если они бесплатны, но они требуют настройки, поэтому я не буду описывать их здесь.Например, с помощью dhl вам необходимо зарегистрировать приложение и зарегистрироваться для отслеживания API Unified и Global, которые необходимо обработать.Кроме того, вы основываете свой тест на длине идентификатора отслеживания, но в некоторых случаях может потребоваться дополнительная информация, например, в StarTrack есть параметры типа и состояния, которые необходимо учитывать.
Имея в виду вышесказанное, вы знаете, что хотите проверить длину идентификатора, результат которого определит курьер.Мы можем логически предположить, что ответ не будет одинаковым, поэтому мы могли бы установить разветвленный код, основанный на длине, который вызывает различные функции, которые обрабатывают запрос отслеживания и синтаксический анализ ответа;включая сбои / не доставленные элементы.
Примечание. Этот тип кода прекрасно подходит для кодирования на основе классов, что, если бы все 3 были вызовами API, я бы определенно сделал.Вы могли бы реализовать несколько хороших интерфейсов для.
Помимо этого, есть способ с доступными в настоящее время для меня конечными точками.В коде есть некоторые дополнительные примечания.
Я включил начальный тестовый саб, просто чтобы вы могли проверить работу всех 3 типов.
Требования к настройке:
Требуются следующие ссылки (VBE> Инструменты> Ссылки):
- Библиотека объектов Microsoft HTML
- Среда выполнения сценариев 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