Как извлечь текст одного элемента HTML по имени тега, используя MSXML в VBA?

Question

Я пытаюсь извлечь титулы US Patent, используя MSXML6.

В полнотекстовом представлении html патентного документа на веб-сайте USPTO название патента появляется как первый и единственный элемент «шрифта», который является дочерним положением «тела».

Вот моя функция, которая не работает (я не получаю ошибки, ячейка с формулой просто остается пустой).

Может кто-нибудь помочь мне выяснить, что не так?

Пример 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.

• Было несколько элементов «шрифта» перед тем, как было указано название.

Это должно работать:

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