WebBrowserのリンク先取得について (ID:121656)

名前

ホームページ(ブログ、Twitterなど)のURL (省略可)

本文

未だ解決していなかったんですね。
簡単なフレーム構成に対応するサンプルを載せておきます。

' 参照設定: Microsoft HTML Object Library (MSHTML.tlb)
Option Explicit
Private m_sFrameLocation As String
Private m_sIFrameLocation As String
Private WithEvents MainDoc As HTMLDocument
Private WithEvents frameDoc As HTMLDocument
Private WithEvents iframeDoc As HTMLDocument

Private Sub Form_Load()
    WebBrowser1.Navigate2 "http://www.bcap.co.jp/hanafusa/index.html"
End Sub

Private Sub WebBrowser1_BeforeNavigate2(ByVal pDisp As Object, URL As Variant, Flags As Variant, TargetFrameName As Variant, PostData As Variant, Headers As Variant, Cancel As Boolean)
    Set MainDoc = Nothing
    Set frameDoc = Nothing
    Set iframeDoc = Nothing
End Sub

Private Sub WebBrowser1_DocumentComplete(ByVal pDisp As Object, URL As Variant)
    If (WebBrowser1.Document Is Nothing) Then Exit Sub
    Set MainDoc = WebBrowser1.Document
End Sub

Private Sub MainDoc_onmouseout()
    Text1.Text = ""
End Sub

Private Sub MainDoc_onmouseover()
    Dim oElement As IHTMLElement
    Set oElement = MainDoc.parentWindow.event.srcElement
    Select Case UCase(oElement.tagName)
    Case "FRAMESET"
    Case "FRAME"
        If (Len(m_sFrameLocation) = 0) Or _
                (m_sFrameLocation <> oElement.LocationURL) Then
            Dim i As Long
            For i = 0 To MainDoc.frames.length - 1
                If (oElement.LocationURL = MainDoc.frames.Item(i).location) Then
                    Set frameDoc = MainDoc.frames.Item(i).Document
                    m_sFrameLocation = MainDoc.frames.Item(i).location
                    Exit For
                End If
            Next
        End If
    Case Else
        Do While (oElement.tagName <> "A")
            Set oElement = oElement.parentElement
            If (oElement Is Nothing) Then Exit Sub
        Loop
        Text1.Text = oElement.innerText & vbNewLine & oElement.href
    End Select
    Set oElement = Nothing
End Sub

Private Sub frameDoc_onmouseout()
    Text1.Text = ""
End Sub

Private Sub frameDoc_onmouseover()
    Dim oElement As IHTMLElement
    Set oElement = frameDoc.parentWindow.event.srcElement
    Select Case UCase(oElement.tagName)
    Case "IFRAME"
        If (Len(m_sIFrameLocation) = 0) Or _
                (m_sIFrameLocation <> oElement.LocationURL) Then
            Dim i As Long
            For i = 0 To frameDoc.frames.length - 1
                If (oElement.LocationURL = frameDoc.frames.Item(i).location) Then
                    Set iframeDoc = frameDoc.frames.Item(i).Document
                    m_sIFrameLocation = frameDoc.frames.Item(i).location
                    Exit For
                End If
            Next
        End If
    Case Else
        Do While (oElement.tagName <> "A")
            Set oElement = oElement.parentElement
            If (oElement Is Nothing) Then Exit Sub
        Loop
        Text1.Text = oElement.innerText & vbNewLine & oElement.href
    End Select
    Set oElement = Nothing
End Sub

Private Sub iframeDoc_onmouseout()
    Text1.Text = ""
End Sub

Private Sub iframeDoc_onmouseover()
    Dim oElement As IHTMLElement
    Set oElement = iframeDoc.parentWindow.event.srcElement
    Do While (oElement.tagName <> "A")
        Set oElement = oElement.parentElement
        If (oElement Is Nothing) Then Exit Sub
    Loop
    Text1.Text = oElement.innerText & vbNewLine & oElement.href
    Set oElement = Nothing
End Sub

←解決時は質問者本人がここをチェックしてください。

戻る