VBA 代码 - 连接到网页并检索值

Question

我有以下

• A 列 == 联邦快递 AWB #s
• B 列 == 交货日期（空）

我想编写一个函数，它读取 A 列上的跟踪号并从网站中提取交货日期 - 所有 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

一个函数，传递空运单号并返回日期就足够了：

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

确保从 VBE 菜单>Extras>References 添加库“Microsoft Internet Controls”：

Answer 2

您可以使用更快的 xmlhttp 请求，而不是使用浏览器。

该页面执行XHR POST 请求，该请求返回您可以解析的json（返回的大量信息包括交货日期字段）。您可以将其用作工作表中的功能。我还展示了一个测试电话。 id（跟踪号）作为参数传递给函数GetDeliveryDate。

这是您在网站上提交跟踪号时提出的请求：

从上面可以看出，并且在代码中进一步详细说明，跟踪号是请求中发送的正文的一部分（数据参数）；它也是请求标头之一的一部分。

我使用jsonconverter.bas 来解析 json 响应。将代码从那里添加到您的项目后，您需要转到 VBE > Tools > References 并添加对 Microsoft Scripting Runtime 的引用。

查看json响应here

正如你所说，所有请求都会返回一个交货日期，如果你不想加载这个外部库，你可以使用split 来隔离日期。

---

相关json：

您可以在此处查看 json 的相关部分：

我使用字段actDeliveryDt 作为使用 split 的代码版本，因为我可以将明确的日期 yyyy-mm-dd 从日期时间字符串中分离出来。我使用displayActDeliveryDt 进行 json 解析，尽管您可以使用其中任何一种（如果使用前者，则使用 split 删除时间部分，如下面的示例所示）

警告：我只有一个交付 ID 可用于测试。

---

待办事项：

1. 您可以添加测试是否发出了有效请求，因为 json 响应包含此字段。

---

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

使用拆分：

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

---

工作表中的示例用法：

注意：我在工作表中有英国格式 dd/mm/yyyy