Question

我有以下

A列== FEdEX运单编号
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菜单>“其他”>“参考”中添加了“ Microsoft Internet Controls”库：

Answer 2

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

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

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

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

我使用jsonconverter.bas来解析json响应。将代码从那里添加到您的项目后，您需要进入VBE>工具>引用，并添加对Microsoft脚本运行时的引用。

查看json响应here

正如您所说，所有请求都将返回交货日期，如果您不想加载此外部库，则可以使用split来分隔日期。

相关json：

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

我将字段actDeliveryDt用于使用split的代码版本，因为我可以将明确的日期yyyy-mm-dd与datetime字符串分开。我可以使用displayActDeliveryDt进行json解析，尽管您可以使用两者（如果使用前者，请使用split删除时间部分，如下面的示例所示）

注意：我只有一个交货ID用于测试。

待办事项：

您可以添加一个测试来确定是否发出了有效请求，因为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

VBA代码-连接到网页并获取价值

2 个答案: