Код VBA - подключиться к веб-странице и получить значение

Question

У меня есть следующее

• Столбец A == FEdEX AWB #s
• Колонка B == Дата доставки (пусто)

Я хотел бы написать функцию, которая считывает номер отслеживания в столбце А и извлекает дату доставки с веб-сайта - все AWB # доставлены - уверен на 100%

Код, который я имею, записывает всю информацию, найденную на веб-сайте, в лист - не уверен, как извлечь только дату доставки.

Sub Macro1()
    With ActiveSheet.QueryTables.Add(Connection:= _
    "URL;https://www.bing.com/packagetrackingv2? 
    packNum=727517426234&carrier=Fedex&FORM=PCKTR1" _
    , Destination:=Range("$A$1"))
    .Name = _
    "https://www.bing.com/packagetrackingv2? 
     packNum=727517426234&carrier=Fedex&FORM=PCKTR1"
    .FieldNames = True
    .RowNumbers = False
    .FillAdjacentFormulas = False
    .PreserveFormatting = True
    .RefreshOnFileOpen = False
    .BackgroundQuery = True
   .RefreshStyle = xlInsertDeleteCells
   .SavePassword = False
   .SaveData = True
   .AdjustColumnWidth = True
   .RefreshPeriod = 0
   .WebSelectionType = xlEntirePage
   .WebFormatting = xlWebFormattingNone
   .WebPreFormattedTextToColumns = True
   .WebConsecutiveDelimitersAsOne = True
   .WebSingleBlockTextImport = False
   .WebDisableDateRecognition = False
   .WebDisableRedirections = False
   .Refresh BackgroundQuery:=False
    End With

End Sub

Answer 1

Вместо использования браузера вы можете использовать запрос xmlhttp, который выполняется быстрее.

Страница выполняет форму XHR POST-запрос, который возвращает json, который вы можете проанализировать (возвращается много информации, включая поле даты доставки). Вы можете использовать это как функцию на листе. Я также показываю тестовый звонок. Идентификатор (номер отслеживания) передается в качестве аргумента функции GetDeliveryDate.

Вот запрос, сделанный при отправке вашего номера для отслеживания на сайте:

Как видно из вышесказанного и более подробно в коде, номер отслеживания является частью тела, отправляемого в запросе (параметр данных); это также часть одного из заголовков запроса.

Я использую jsonconverter.bas для анализа ответа json. После добавления кода оттуда в ваш проект вам нужно перейти в VBE> Инструменты> Ссылки и добавить ссылку на Microsoft Scripting Runtime.

Просмотр ответа json здесь

Как вы говорите, все запросы будут возвращать дату доставки, если вы не хотите загружать эту внешнюю библиотеку, вы можете использовать split, чтобы изолировать дату.

---

Соответствующий JSON:

Вы можете увидеть соответствующую часть JSON здесь:

Я использую поле actDeliveryDt для версии кода с использованием split, поскольку я могу отделить однозначную дату yyyy-mm-dd от строки datetime. Я использую displayActDeliveryDt для разбора json, хотя вы можете использовать любой из них (удаление временной части с помощью split, если используется первый, как показано в примерах ниже)

Предупреждение: у меня был только один идентификатор доставки для использования.

---

TODO:

1. Вы можете добавить в тест информацию о том, был ли сделан правильный запрос, поскольку в ответе json есть поле для этого.
2. При выполнении этого для нескольких запросов я бы порекомендовал для эффективности переписать с использованием подпрограммы, которая зацикливает массив номеров отслеживания, сохраняет результаты в массиве и записывает этот массив в конец.

---

VBA:

Разбор JSON:

Option Explicit 'example test call from VBE
Public Sub test()    
    Debug.Print GetDeliveryDate(727517426234#)
End Sub

 Public Function GetDeliveryDate(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_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
        Set json = JsonConverter.ParseJson(.responseText)
    End With
    GetDeliveryDate = json("TrackPackagesResponse")("packageList")(1)("displayActDeliveryDt")
End Function

Использование split:

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

---

Пример использования в листе:

Примечание: у меня есть британский формат дд / мм / гггг в листе

Answer 2

Функция, позволяющая передать номер счета-фактуры и вернуть дату, будет вполне достаточной:

Function GetDateFromAwb(awbNumber As String) As String

    Dim objIE As New InternetExplorer   'Microsoft Internet Controls library added
    objIE.Visible = False               'Or put True, if you want to see the IE

    objIE.navigate "https://www.fedex.com/apps/fedextrack/?tracknumbers=" & awbNumber

    Do While objIE.Busy = True Or objIE.readyState <> 4: DoEvents: Loop
    Application.Wait (Now + TimeValue("0:00:05"))

    GetDateFromAwb = objIE.Document.getElementsByClassName("redesignSnapshotTVC snapshotController_date dest").Item.InnerText
    objIE.Quit

End Function

Смысл этой функции заключается в добавлении номера строки аэрологической накладной в URL и открытии соответствующейсайт.Затем, используя класс "redesignSnapshotTVC snapshotController_date dest", берется соответствующая дата.

Это возможный способ вызова функции, отображающий дату в MsgBox:

Sub Main()

    Dim awbNumber As String
    awbNumber = 727517426234#
    Dim awbDate As String

    awbDate = GetDateFromAwb(awbNumber)
    MsgBox awbDate

End Sub

Makeубедитесь, что библиотека «Microsoft Internet Controls» добавлена ​​из меню VBE> Доп. функции> Ссылки: