如何枚举网页中的全部链接？

Question

如何枚举网页中的全部链接？

Answer 1

Private Sub GetLinks()
  Dim Doc As IHTMLDocument2
  Dim All As IHTMLElementCollection
  Dim L As Integer
  Dim i As Integer
  Dim Varl As Variant  Set Doc = WebBrowser1.document
  Set All = Doc.links
  L = All.length
  For i = 0 To L - 1
    Set Varl = All.Item(i, varempty)
    List1.AddItem ("链接名称：" & Varl.innerText & "   链接地址：" & Varl.href)
    Set Varl = Nothing
  Next i
  Set All = Nothing
  Set Doc = Nothing
End Sub

Answer 2

'form1.code
Option ExplicitDim ExWinsPrivate Sub Form_Load()
    Dim winShell                                    As Object
    Dim WebB                                        As WebBrowser_V1
    Dim IEwin                                       As Object
    Dim LVItem                                      As ListItem
    
    Set winShell = CreateObject("shell.application")
    Set ExWins = winShell.windows
    For Each WebB In ExWins
        Set LVItem = Me.LVieWin.ListItems.Add(, , WebB.LocationName)
            LVItem.SubItems(1) = WebB.LocationURL
    Next
    Set winShell = Nothing
    
End SubPrivate Sub IP过滤_Click()
    Dim 过滤地址                                    As String
    Dim i                                           As Long
    Dim LVItem                                      As ListItem
    
    If Me.LVlinks.SelectedItem Is Nothing Then Exit Sub
    过滤地址 = InputBox("输入过滤地址", "输入框", Me.LVlinks.SelectedItem.SubItems(1))
    If 过滤地址 = "" Then Exit Sub
    For i = 1 To Me.LVlinks.ListItems.Count
        If InStr(Me.LVlinks.ListItems(i).SubItems(1), 过滤地址) Then
            Set LVItem = Me.LV过滤.ListItems.Add(, , Me.LVlinks.ListItems(i).Text)
                LVItem.SubItems(1) = Me.LVlinks.ListItems(i).SubItems(1)
        End If
    Next
End SubPrivate Sub LVieWin_ItemClick(ByVal Item As MSComctlLib.ListItem)
    Dim IEwin                                       As WebBrowser_V1
    Dim IEdocument                                  As HTMLDocument
    Dim Link                                        As HTMLAnchorElement
    Dim LVItem                                      As ListItem
    On Error Resume Next
    '───错误保护结构───'
        'Me.LVlinks.ListItems.Clear
        
        Set IEwin = ExWins(Item.Index - 1)
        Set IEdocument = IEwin.Document
        If Not IEdocument.links Is Nothing Then
            If Not Err Then
                For Each Link In IEdocument.links
                    Set LVItem = Me.LVlinks.ListItems.Add(, , Link.innerText)
                        LVItem.SubItems(1) = Link.href
                Next
            End If
        End If
        
        If Not IEdocument.activeElement.contentWindow Is Nothing Then
            If Not Error Then ' 如果掉用对象不成功则不执行
                For Each Link In IEdocument.activeElement.contentWindow.Document.activeElement.contentWindow.Document.links
                    Set LVItem = Me.LVlinks.ListItems.Add(, , Link.innerText)
                        LVItem.SubItems(1) = Link.href
                Next
            End If
        End If    '───错误保护结构───'
    On Error GoTo 0    
    
End SubPrivate Sub LVlinks_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
    Me.LVlinks.SortKey = ColumnHeader.Index - 1
    Me.LVlinks.Sorted = True
End SubPrivate Sub LVlinks_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = 2 Then
        Me.PopupMenu Me.IPaddres
    End If
End SubPrivate Sub LV过滤_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
    Me.LV过滤.SortKey = ColumnHeader.Index - 1
    Me.LV过滤.Sorted = True
End SubPrivate Sub LV过滤_DblClick()
    Dim i As Long
    
    For i = 1 To Me.LV过滤.ListItems.Count
        If Me.LV过滤.ListItems(i).Checked Then
            Debug.Print Me.LV过滤.ListItems(i).Text
            Debug.Print Me.LV过滤.ListItems(i).SubItems(1)
        End If
    Next
End Sub