为啥我无法使用 MSXML2 和 VBA 将 HTML 类名添加到元素集合

Posted 2023-03-16

【中文标题】为啥我无法使用 MSXML2 和 VBA 将 HTML 类名添加到元素集合

【英文标题】：Why am I not able to add an HTML Classname to an Element Collection using MSXML2 with VBA为什么我无法使用 MSXML2 和 VBA 将 HTML 类名添加到元素集合

【发布时间】：2021-11-11 22:32:35

【问题描述】：

我从各种帖子中尝试了许多行之有效的方法来从网页中获取一些数据，但均未成功。我可以在打开的页面上获得链接项目的列表，但是一旦我导航到任何其他页面，我就会用下面的代码画一个空白。

当我运行代码时，我在 Cats 中没有得到任何结果。

Sub Main()
Dim XMLReq As New MSXML2.XMLHTTP60
Dim htmlDoc As New MSHTML.HTMLDocument

Dim Cats As MSHTML.IHTMLElementCollection
Dim Cat As MSHTML.IHTMLElement
Dim NextHref As String
Dim NextURL As String

XMLReq.Open "GET", URL, False
XMLReq.send

If XMLReq.Status <> 200 Then
    MsgBox "Problem"
    Exit Sub
End If

HTMLDoc.body.innerHTML = XMLReq.responseText
Set XMLReq = Nothing

Set Cats = HTMLDoc.getElementsByClassName("ng-tns-c329-5 product-grid--tile ng-star-inserted")

Debug.Print Cats.Length 'Returns 0

'For Each Cat In Cats
'    NextHref = Cat.getAttribute("href")
'    NextURL = URL & Mid(NextHref, InStr(NextHref, ":") + 2)
'    ListItemsInCats Cat.innerText, NextURL

'Next Cat

End Sub

Expanded Element structure

Collased structure

感谢您的帮助。

【问题讨论】：

有问题的 URL 是什么？我猜这是来自谷歌搜索的 Woolworth，但“打开页面”的确切 URL 是什么？数据来自 API，因此您不会从 HTML 文档中找到任何内容。

谢谢雷蒙德。打开页面的完整内容是 = URL 是 woolworths.com.au。导航页面为 = woolworths.com.au/shop/browse/bakery

您能否说明您在每种产品中寻找哪些信息？只是产品的名称和价格（如果打折、不打折还是打折？）？

是的，雷蒙德。这正是我正在寻找的。​​span>

我想整理一份产品清单，并将它们与其他商店进行比较，以作为活动和随后的节省。

【参考方案1】：

您尝试从中抓取的网站的问题在于：

在 XMLHTTP 请求方法中 - 产品详细信息是从 Fetch/XHR 中提取的动态内容，XMLHTTP 不运行，XMLHTTP 只为您提供 HTML 文档，没有任何脚本运行。

在 Internet Explorer 方法中 - 网页在实际加载产品详细信息之前被认为已准备就绪，因此对 Busy 和 ReadyState 的常规循环检查是不够的。

下面的代码使用 Internet Explorer 并解决上述问题，我进行了一些检查（我相信这并不完美，但到目前为止它在我的测试中有效）将等到第一个产品被加载之前继续提取产品详细信息：

Private Sub GetBakeryProducts()
    Const URL As String = "https://www.woolworths.com.au/shop/browse/bakery"
    
    Dim ieObj As InternetExplorer
    Set ieObj = New InternetExplorer
    
    ieObj.navigate URL
    ieObj.Visible = True
    
    Do While ieObj.Busy Or ieObj.readyState <> READYSTATE_COMPLETE
        DoEvents
    Loop
    
    Do While ieObj.document.getElementsByClassName("productCarousel-header").Length = 0
        DoEvents
    Loop
        
    Dim ieDoc As MSHTML.HTMLDocument
    Set ieDoc = ieObj.document

    Dim productList As Object
    Set productList = ieDoc.getElementsByClassName("product-grid--tile")
        
    '==== Test if the website has finish loading the 1st product details
    On Error Resume Next
    Dim testStatus As String
    Do
        Err.Clear
        testStatus = productList(0).getElementsByClassName("shelfProductTile-descriptionLink")(0).innerText
    Loop Until Err.Number = 0
    '====
    
    Dim outputArr() As String
    ReDim outputArr(1 To productList.Length, 1 To 2) As String
    Dim outputIndex As Long
    
    Dim i As Long
    For i = 0 To productList.Length - 1
        If productList(i).getElementsByClassName("shelfProductTile-descriptionLink").Length <> 0 Then
            If Err.Number <> 0 Then
                Err.Clear
                Exit For
            End If
            
            Dim productName As String
            Dim productPrice As String
            
            productName = productList(i).getElementsByClassName("shelfProductTile-descriptionLink")(0).innerText
            productPrice = Replace(productList(i).getElementsByClassName("price")(0).innerText, vbNewLine, vbNullString)
            
            outputIndex = outputIndex + 1
            outputArr(outputIndex, 1) = productName
            outputArr(outputIndex, 2) = productPrice
        End If
    Next i
    
    ReDim Preserve outputArr(1 To outputIndex, 1 To 2) As String
    
    ieObj.Quit
    Set ieObj = Nothing
    
    ThisWorkbook.Sheets("Sheet1").Range("A1").Resize(outputIndex, UBound(outputArr, 2)).Value = outputArr
End Sub

运行此程序将从网站中提取数据并将输出从单元格 A1 开始粘贴到 Sheet1 中，请根据需要更改工作表名称和范围。

【讨论】：

@QHarr 感谢您强调这一点，我忘了提到我实际上是指他对我的评论说他尝试使用 IE 但结果相同。你是对的，他在他的问题中的问题是由于 XHR 请求不是在 xmlhttp 中提出的。

@QHarr 已编辑详细说明这两种方法的问题，谢谢！

感谢所有花时间提供帮助的人。提供的代码虽然速度较慢，但​​有时我们需要妥协。很努力。谢谢你。

@John 如果某个答案解决了您的问题，我们鼓励您通过单击旁边的勾号来接受它（如果有多个答案，您只能接受一个）。

为什么我在任何地方都看不到勾号？