HTML 内の URL 解析

HTML 内の URL を解析してみるテスト。とりあえず A タグの URL だけ Debug.Print してみる。

MSHTML を使った例

Public Sub FindAnchorUrl1(ByVal HtmlPath As String)
    Dim HtmlDocument As MSHTML.HtmlDocument
    Set HtmlDocument = New MSHTML.HtmlDocument

    Dim Html As MSHTML.HtmlDocument
    Set Html = HtmlDocument.createDocumentFromUrl(HtmlPath, vbNullString)

    Do
        ' 本来は Sleep を使うべき
        ' テスト用に作ったので仮で DoEvents を使用
        DoEvents

        If Html.readyState = "complete" Then
            Exit Do
        End If
    Loop While True

    Dim Anchors As IHTMLElementCollection
    Set Anchors = Html.getElementsByTagName("A")

    Dim Anchor As HTMLAnchorElement
    For Each Anchor In Anchors
        Debug.Print Anchor.href
    Next
End Sub

地道にテキストを解析した例

※テスト用に書いたコードそのままなので、
　リファクタリングはまったくしてないです。ご容赦。
　ちなみに、HTML ファイルはローカルにあるのを前提とします。

Private FileSystemObject As New FileSystemObject

Public Sub FindAnchorUrl2(ByVal HtmlPath As String)
    Dim Stream As TextStream
    Set Stream = FileSystemObject.OpenTextFile(HtmlPath)

    Dim Text As String
    Text = Stream.ReadAll()

    Dim Find As String
    Find = Strings.LCase$(Text)

    Dim i As Long
    i = 1

    Do
        Dim AnchorIndex As Long
        AnchorIndex = Strings.InStr(i, Find, "<a", vbBinaryCompare)

        If AnchorIndex <> 0 And AnchorIndex < Len(Text) Then
            Dim HrefIndex As Long
            HrefIndex = Strings.InStr(AnchorIndex, Find, "href=", vbBinaryCompare)

            If HrefIndex <> 0 And HrefIndex < Len(Text) Then
                Dim UrlIndex As Long
                UrlIndex = HrefIndex + Len("href=")

                If Strings.Mid$(Find, UrlIndex, 1) = """" Then
                    UrlIndex = UrlIndex + 1
                End If

                Dim UrlLast As Long
                UrlLast = Strings.InStr(UrlIndex, Find, """", vbBinaryCompare)

                If UrlLast = 0 Then
                    UrlLast = Strings.InStr(UrlIndex, Find, " ", vbBinaryCompare)
                End If

                If UrlLast = 0 Then
                    Debug.Print "URL 取得失敗。"
                    i = UrlIndex
                Else
                    Debug.Print Mid$(Text, UrlIndex, UrlLast - UrlIndex)
                    i = UrlLast
                End If
            Else
                Exit Do
            End If

        Else
            Exit Do
        End If
    Loop Until Len(Text) < i

    Call Stream.Close
End Sub

参考

Web ページをダウンロードする方法～ MSHTML 編～
http://www.f3.dion.ne.jp/~element/msaccess/AcTipsMSHTML.html