如何在不在 vba 中创建 Internet Explorer 对象的情况下解析 html？

Question

我在工作的任何计算机上都没有 Internet Explorer，因此无法创建 Internet Explorer 对象并使用 ie.navigate 解析 html 并搜索标签。我的问题是，如何在不使用 IE 的情况下自动将带有标签的某些数据从框架源提取到我的电子表格？答案中的代码示例将非常有用:) 谢谢

Answer 1

任何做过网页抓取的人都会熟悉如何创建 Internet Explorer (IE) 实例和导航到一个网址，然后在页面准备就绪后开始使用“Microsoft HTML 对象库”（ MSHTML) 类型库。问题询问如果 IE 不可用怎么办。对于运行 Windows 10 的机器，我的情况与此相同。

我曾怀疑可以独立于 IE 启动 MSHTML.HTMLDocument 的实例，但它的创建并不明显。感谢提问者现在提出这个问题。答案在于MSHTML.IHTMLDocument4.createDocumentFromUrl 方法。需要一个本地文件才能工作（编辑：实际上也可以放入一个 webby url！），但是我们有一个非常整洁的 Windows API 函数，称为 URLDownloadToFile 来下载文件。

此代码在运行 Microsoft Edge 而不是 Internet Explorer 的 Windows 10 机器上运行。这是一个重要的发现，感谢提问者提出这个问题。

Option Explicit

'* Tools->Refernces Microsoft HTML Object Library


'* MSDN - URLDownloadToFile function - https://msdn.microsoft.com/en-us/library/ms775123(v=vs.85).aspx
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
        (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, _
        ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long

Sub Test()

    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")

    Dim sLocalFilename As String
    sLocalFilename = Environ$("TMP") & "\urlmon.html"

    Dim sURL As String
    sURL = "https://stackoverflow.com/users/3607273/s-meaden"


    Dim bOk As Boolean
    bOk = (URLDownloadToFile(0, sURL, sLocalFilename, 0, 0) = 0)
    If bOk Then
        If fso.FileExists(sLocalFilename) Then

            '* Tools->Refernces Microsoft HTML Object Library
            Dim oHtml4 As MSHTML.IHTMLDocument4
            Set oHtml4 = New MSHTML.HTMLDocument

            Dim oHtml As MSHTML.HTMLDocument
            Set oHtml = Nothing

            '* IHTMLDocument4.createDocumentFromUrl
            '* MSDN - IHTMLDocument4 createDocumentFromUrl method - https://msdn.microsoft.com/en-us/library/aa752523(v=vs.85).aspx
            Set oHtml = oHtml4.createDocumentFromUrl(sLocalFilename, "")

            '* need to wait a little whilst the document parses
            '* because it is multithreaded
            While oHtml.readyState <> "complete"
                DoEvents  '* do not comment this out it is required to break into the code if in infinite loop
            Wend
            Debug.Assert oHtml.readyState = "complete"


            Dim sTest As String
            sTest = Left$(oHtml.body.outerHTML, 100)
            Debug.Assert Len(Trim(sTest)) > 50  '* just testing we got a substantial block of text, feel free to delete

            '* page specific logic goes here
            Dim htmlAnswers As Object 'MSHTML.DispHTMLElementCollection
            Set htmlAnswers = oHtml.getElementsByClassName("answer-hyperlink")

            Dim lAnswerLoop As Long
            For lAnswerLoop = 0 To htmlAnswers.Length - 1
                Dim vAnswerLoop
                Set vAnswerLoop = htmlAnswers.Item(lAnswerLoop)
                Debug.Print vAnswerLoop.outerText

            Next

        End If
    End If
End Sub

感谢您提出这个问题。

附：我已经使用 TaskList 来验证当这段代码运行时 IExplore.exe 不是在后台创建的。

P.P.S 如果您喜欢这篇文章，请在我的Excel Development Platform blog查看更多内容

Answer 2

您可以使用 XMLHTTP 来检索网页的 HTML 源代码：

Function GetHTML(url As String) As String
    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", url, False
        .Send
        GetHTML = .ResponseText
    End With
End Function

我不建议将其用作工作表函数，否则每次重新计算工作表时都会重新查询站点 URL。一些网站有适当的逻辑来检测通过频繁、重复调用的抓取，并且您的 IP 可能会暂时或永久地被禁止，具体取决于网站。

一旦你有了源 HTML 字符串（最好存储在一个变量中以避免不必要的重复调用），你可以使用基本的文本函数来解析字符串来搜索你的标签。

这个基本函数将返回 <tag> 和 </tag> 之间的值：

Public Function getTag(url As String, tag As String, Optional occurNum As Integer) As String
    Dim html As String, pStart As Long, pEnd As Long, o As Integer
    html = GetHTML(url)

    'remove <> if they exist so we can add our own
    If Left(tag, 1) = "<" And Right(tag, 1) = ">" Then
        tag = Left(Right(tag, Len(tag) - 1), Len(Right(tag, Len(tag) - 1)) - 1)
    End If

    ' default to Occurrence #1
    If occurNum = 0 Then occurNum = 1
    pEnd = 1

    For o = 1 To occurNum
        ' find start <tag> beginning at 1 (or after previous Occurence)
        pStart = InStr(pEnd, html, "<" & tag & ">", vbTextCompare)
        If pStart = 0 Then
            getTag = "{Not Found}"
            Exit Function
        End If
        pStart = pStart + Len("<" & tag & ">")

        ' find first end </tag> after start <tag>
        pEnd = InStr(pStart, html, "</" & tag & ">", vbTextCompare)
    Next o

    'return string between start <tag> & end </tag>
    getTag = Mid(html, pStart, pEnd - pStart)
End Function

这只会找到基本的 <tag>，但您可以添加/删除/更改文本功能以满足您的需要。

示例用法：

Sub findTagExample()

    Const testURL = "https://en.wikipedia.org/wiki/Web_scraping"

    'search for 2nd occurence of tag: <h2> which is "Contents" :
    Debug.Print getTag(testURL, "<h2>", 2)

    '...this returns the 8th occurence, "Navigation Menu" :
    Debug.Print getTag(testURL, "<h2>", 8)

    '...and this returns an HTML <span> containing a title for the 'Legal Issues' section:
    Debug.Print getTag("https://en.wikipedia.org/wiki/Web_scraping", "<h2>", 4)

End Sub