如何在 VBA 中使用 MSXML 按标签名称提取单个 HTML 元素的文本？

Question

我正在尝试使用 MSXML6 提取美国专利标题。

在 USPTO 网站上的专利文件的 full-text html 视图中，专利名称作为第一个也是唯一的 "font" 元素出现 child共 "body".

我的函数不起作用（我没有收到任何错误；带有公式的单元格保持空白）。

谁能帮我找出问题所在？

我输入函数的一个例子 URL 是 http://patft.uspto.gov/netacgi/nph-Parser?Sect1=PTO1&Sect2=HITOFF&d=PALL&p=1&u=%2Fnetahtml%2FPTO%2Fsrchnum.htm&r=1&f=G&l=50&s1=6293874.PN.&OS=PN/6293874&RS=PN/6293874

Function getUSPatentTitle(url As String)
    Static colTitle As New Collection
    Dim title As String
    Dim pageSource As String

    Dim xDoc As MSXML2.DOMDocument
    Dim xNode As IXMLDOMNode

    On Error Resume Next

    title = colTitle(url)
    If Err.Number <> 0 Then
        Set html_doc = CreateObject("htmlfile")
        Set xml_obj = CreateObject("MSXML6.XMLHTTP60")

        xml_obj.Open "GET", url, False
        xml_obj.send
        pageSource = xml_obj.responseText
        Set xml_obj = Nothing

        Set xDoc = New MSXML2.DOMDocument
        If Not xDoc.LoadXML(pageSource) Then  
            Err.Raise xDoc.parseError.ErrorCode, , xDoc.parseError.reason
        End If

        Set xNode = xDoc.getElementsByTagName("font").Item(1)

        title = xNode.Text
        If Not title = "" Then colTitle.Add Item:=title, Key:=url
    End If

    On Error GoTo 0 ' I understand "GoTo" is dangerous coding but copied from somebody and so far haven't thought of a more natural substitute for a GoTo statement

    getUSPatentTitle = title
End Function

Answer 1

几点：

"On Error Goto 0" 并不是真正的传统 Goto 语句——它只是您在 VBA 中关闭用户错误处理的方式。您的代码中有一些错误，但 "On Error Resume Next" 跳过了它们，因此您什么也没看到。
来自网页的数据是 HTML 格式而不是 XML.
在带有标题的元素之前有一些 "font" 个元素。

这应该有效：

Function getUSPatentTitle(url As String)
    Static colTitle As New Collection
    Dim title As String
    Dim pageSource As String
    Dim errorNumber As Integer

    On Error Resume Next
    title = colTitle(url)
    errorNumber = Err.Number
    On Error GoTo 0

    If errorNumber <> 0 Then
        Dim xml_obj As XMLHTTP60
        Set xml_obj = CreateObject("MSXML2.XMLHTTP")
        xml_obj.Open "GET", url, False
        xml_obj.send
        pageSource = xml_obj.responseText
        Set xml_obj = Nothing

        Dim html_doc As HTMLDocument
        Set html_doc = CreateObject("HTMLFile")
        html_doc.body.innerHTML = pageSource

        Dim fontElement As IHTMLElement
        Set fontElement = html_doc.getElementsByTagName("font").Item(3)

        title = fontElement.innerText
        If Not title = "" Then colTitle.Add Item:=title, Key:=url
    End If

    getUSPatentTitle = title
End Function

Answer 2

CSS 选择器：

您可以重写您描述的内容，这实际上是 body 标签中的第一个 font 标签作为 CSS 选择器：

body > font

CSS查询：

VBA:

因为这是您想要的第一个 match/only，您可以使用 document 的 querySelector 方法来应用选择器并检索单个元素。

Debug.Print html_doc.querySelector("body > font").innerText

您可能需要添加对 HTML Object Library 的引用并使用 Dim html_doc As HTMLDocument 的早期绑定调用来访问该方法。后期绑定方法可能公开 querySelector 方法，但如果接口不使用早期绑定。

如何在 VBA 中使用 MSXML 按标签名称提取单个 HTML 元素的文本？

How do I extract text of a single HTML element by tag name using MSXML in VBA?

html

vba

msxml

msxml6