Comment extraire le texte d'un seul élément HTML par nom de tag à l'aide de MSXML dans VBA?

Question

J'essaie d'extraire des titres de brevets américains en utilisant MSXML6. Sur la vue html texte intégral d'un document de brevet sur le site Web de l'USPTO, le titre du brevet apparaît comme le premier et unique élément "police" qui est un enfant de "corps".

Voici ma fonction qui ne fonctionne pas (je n'obtiens aucune erreur, la cellule avec la formule reste vide).

Quelqu'un peut-il m'aider à comprendre ce qui ne va pas?

Un exemple d'URL que je nourrissais dans la fonction est 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

Juste quelques points:

• "On Error Goto 0" est pas vraiment une déclaration traditionnelle Goto - il est juste comment vous désactivez la gestion des erreurs de l'utilisateur dans VBA. Il y a eu quelques erreurs dans votre code mais le message "On Error Resume Next" les a ignorés et vous n'avez rien vu.

• Les données de la page Web sont au format HTML et non XML.

• Il y avait quelques éléments "font" avant celui avec le titre.

Cela devrait fonctionner:

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