Liste Hyperlinks

Public Sub ListeHyperlinks()
Dim objMSHTML As New MSHTML.HTMLDocument
Dim objDocument As MSHTML.HTMLDocument
Dim objLink As HTMLLinkElement
Dim wksZiel As Worksheet
Dim strURL As String
Dim lngZeile As Long

'Verweis: Microsoft HTML Object Library (MSHTML.TLB)

On Error GoTo Fehler

Set wksZiel = Tabelle1
wksZiel.Cells.Clear
lngZeile = 5

strURL = "http://google.de" 'URL anpassen
Set objDocument = objMSHTML.createDocumentFromUrl(strURL, vbNullString)

  While objDocument.readyState <> "complete"
    DoEvents
  Wend

  With wksZiel
    .Range("B1") = strURL
    .Range("B2") = objDocument.Title

    'alle Links der Seite auflisten
    For Each objLink In objDocument.Links

      .Cells(lngZeile, 2).Hyperlinks.Add .Cells(lngZeile, 2), _
                          Address:=objLink, _
                          TextToDisplay:=objLink.innerText

      .Cells(lngZeile, 4) = objLink.outerHTML

      lngZeile = lngZeile + 1
    Next objLink
  End With

wksZiel.Columns("B:B").Font.Underline = xlUnderlineStyleNone
Set wksZiel = Nothing
Set objDocument = Nothing
Set objMSHTML = Nothing
MsgBox "OK", , ""
Exit Sub

Fehler:
    Set wksZiel = Nothing
    Set objDocument = Nothing
    Set objMSHTML = Nothing
    MsgBox "Fehler-Nr.:" & Err.Number & vbNewLine & vbNewLine & _
           "Beschreibung: " & Err.Description, , "Fehler!"
End Sub