如何使用Excel VBA查找/提取属性大小为“+ 1”的HTML“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
（更新：正如所指出的那样，专利标题没有被标记为“标题”，然而它一直出现在网页上的“摘要”之上）。在大多数情况下，它是在“身体”的第七个子元素中，或文件中的第三个“字体”元素，但偶尔会在页面顶部注明“**请查看图像：（更正证书）**”或“（复审证书）”两种方法混淆通过在标题之前插入一个额外的“body”子元素和三个额外的“font”元素来提取。
然而，标题看起来一直是具有“+1”值的属性“size”的第一个“font”元素。 不幸的是，其他元素的大小等于“ – 1”，包括前面提到的并不总是存在的元素，所以必须具体指定这个属性和值。 我已经search，但无法弄清楚如何获取元素的属性和价值。 这是我的代码：
Function Test_UpdateTitle(url As String) Dim title As String Dim pageSource As String 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 'Methods 1 and 2 fail in cases of a certificate of correction or reexamination certificate 'Method 1 ' Dim body As IHTMLElement ' Set body = html_doc.getElementsByTagName("body").Item(0) ' Set fontElement = body.Children(6) 'Method 2 ' Set fontElement = html_doc.getElementsByTagName("font").Item(3) 'Method 3 Dim n As Integer For n = 3 To html_doc.getElementsByTagName("font").Length - 1 Set fontElement = html_doc.getElementsByTagName("font").Item(n) If InStr(fontElement.innerText, "Please see") = 0 And _ InStr(fontElement.innerText, "( Certificate of Correction )") = 0 And _ InStr(fontElement.innerText, "( Reexamination Certificate )") = 0 And _ InStr(fontElement.innerText, " **") = 0 Then Test_UpdateTitle = fontElement.innerText Exit Function End If Next n End Function 我应该补充一点，“**”不会跳过最后一个元素<b> **</b>并且我得到“**”作为标题，在那里有通知请看图像。 在这种情况下星号是通配符吗？
你可以试试这个 只要它的尺寸属性和值为“+1”的第一个字体标签，这应该工作。 我只用三个不同的页面进行了testing，但都返回了正确的结果。
Function Test_UpdateTitle(url) title = "Title Not Found!" Set xml_obj = CreateObject("MSXML2.XMLHTTP") xml_obj.Open "GET", url, False xml_obj.send pageSource = xml_obj.responseText Set xml_obj = Nothing Set document = CreateObject("HTMLFile") document.write pageSource For i = 0 To document.getElementsByTagName("font").length - 1 If document.getElementsByTagName("font")(i).size = "+1" Then title = document.getElementsByTagName("font")(i).innerText Exit For End If Next Test_UpdateTitle = title End Function MsgBox Test_UpdateTitle("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") MsgBox Test_UpdateTitle("http://patft.uspto.gov/netacgi/nph-Parser?Sect1=PTO2&Sect2=HITOFF&p=1&u=%2Fnetahtml%2FPTO%2Fsearch-bool.html&r=1&f=G&l=50&co1=AND&d=PTXT&s1=fight.TI.&OS=TTL/fight&RS=TTL/fight") MsgBox Test_UpdateTitle("http://patft.uspto.gov/netacgi/nph-Parser?Sect1=PTO2&Sect2=HITOFF&u=%2Fnetahtml%2FPTO%2Fsearch-adv.htm&r=14&f=G&l=50&d=PTXT&p=1&S1=search&OS=search&RS=search")
这个答案有些不完整，因为我的Excel不会这样做：
Dim xml_obj As XMLHTTP60 Set xml_obj = CreateObject("MSXML2.XMLHTTP")
但我认为这可能是一个首选方法。
而不是使用USPTO的网站，那么使用Google的？
点击此url： http ： //www.google.com/patents/US6293874
请注意，该专利号码在该URL中很明显。
然后，在你的函数中，只需拉取名为invention-title标签即可。
Set titleElement = html_doc.getElementsByTagName("invention-title").Item(0) title = titleElement.innerText MsgBox(title)
如果您在该页面上查看源代码，则只有其中一个。
如果您打开这个替代方法，从您拥有的URL中parsing专利号码会相对容易，而且我认为提取invention-title会更可靠。
看看这个答案是否按预期工作。 确保您的工作簿中有以下库的引用：
Microsoft XML，v6.0 Microsoft HTML对象库
如果您不确定如何将这些添加到Excel只是给这个链接添加链接引用添加
Option Explicit Sub Test() Debug.Print Test_UpdateTitle("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") End Sub Function Test_UpdateTitle(ByVal strURL As String) As String Dim oHTTP As MSXML2.XMLHTTP60 Dim oDoc As MSHTML.HTMLDocument Dim oFontTags As Variant Dim oFontTag As HTMLFontElement Dim strInnerText As String Dim strSize As String ' Create the http object and send it. Set oHTTP = New MSXML2.XMLHTTP60 oHTTP.Open "GET", strURL, False oHTTP.send ' Make sure that get the a reponse back If oHTTP.Status = 200 Then Set oDoc = New HTMLDocument oDoc.body.innerHTML = oHTTP.responseText Set oFontTags = oDoc.getElementsByTagName("font") ' Go through all the tags. For Each oFontTag In oFontTags 'Get the inner text and size of each tag. strInnerText = oFontTag.innerText strSize = oFontTag.getAttributeNode("size").Value 'Compare to make sure you have what's needed If InStr(strInnertText, "Please see") = 0 And _ InStr(strInnertText, "( Certificate of Correction )") = 0 And _ InStr(strInnertText, "( Reexamination Certificate )") = 0 And _ InStr(strInnertText, " **") = 0 Then If strSize = "+1" Then Test_UpdateTitle = strInnerText Exit Function End If End If Next oFontTag End If End Function
我希望这有帮助。 🙂