如何在VBA中使用MSXML通過標籤名稱提取單個HTML元素的文本？

Question

我正試圖使用​​MSXML6提取美國專利。

在USPTO網站上專利文獻的全文html視圖中，專利標題顯示爲第一個也是唯一一個「body」子元素的「font」元素。

這是我的功能不工作（我沒有錯誤;公式的單元格保持空白）。

有人能幫我弄清楚什麼是錯的嗎？

，我送入功能的一個例子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

就在幾個點：

• 「對錯誤轉到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