Rubrik: HTML/Internet/Netzwerk · HTML/Email | VB-Versionen: VB4, VB5, VB6 | 12.01.02 |
Die nachfolgende Funktion ermittelt alle URL-Linkadressen eines HTML-Seitenquelltextes und gibt diese als String-Array zurück.
Private Function HTML_GetAllURLs( _
ByVal sHTMLText As String) As Variant
' Alle URL-Adressen im übergebenen HTML-Text suchen
' und als Array zurückgeben
Dim sPos As Long
Dim ePos As Long
Dim hPos As Integer
Dim nCount As Long
Dim sTemp As String
Dim sLink As String
Dim sURL() As String
nCount = 0
If sHTMLText <> "" Then
' an erster Position begonnen
sPos = 1
Do
' nach einleitendem Link-Tag suchen "<a"
sPos = InStr(sPos, LCase$(sHTMLText), "<a ")
If sPos > 0 Then
' <a - Tag gefunden, jetzt End-Tag suchen
ePos = InStr(sPos, sHTMLText, ">")
If ePos > 0 Then
' End-Tag gefunden
' jetzt alles zwischen sPos und ePos filtern
sTemp = Mid$(sHTMLText, sPos, ePos - sPos)
If InStr(Mid$(sTemp, 2), "<") = 0 Then
' nur wenn < nicht nochmals vorhanden ist
sTemp = Mid$(sTemp, 4)
' jetzt nach dem Schlüsselwort "HREF" suchen
hPos = InStr(LCase$(sTemp), "href=")
If hPos > 0 Then
' gefunden... jetzt die Link-Adresse auslesen
sLink = Mid$(sTemp, hPos + 5)
' Prüfen, ob "-Zeichen vorhanden,
' wenn ja - "ausschneiden"
If Left$(sLink, 1) = Chr$(34) Then
sLink = Mid$(sLink, 2)
sLink = strLeft(sLink, Chr$(34))
Else
sLink = strLeft(sLink, " ")
End If
If Right$(sLink, 1) = Chr$(34) Then _
sLink = Left$(sLink, Len(sLink) - 1)
' Link in URL-Array speichern
ReDim Preserve sURL(nCount)
sURL(nCount) = sLink
nCount = nCount + 1
' Weitersuche ab "ePos"
sPos = ePos - 1
End If
End If
End If
sPos = sPos + 1
Else
Exit Do
End If
Loop
End If
HTML_GetAllURLs = sURL
End Function
' Hilfsfunktion
Public Function strLeft(ByVal sString As String, _
ByVal vDelimiter As Variant) As String
Dim lPos As Long
If VarType(vDelimiter) = vbString Then
' String bis zum ersten Vorkommen eines Zeichens
' zurückgeben
lPos = InStr(sString, vDelimiter)
If lPos = 0 Then lPos = Len(sString)
Else
lPos = Val(vDelimiter)
End If
strLeft = Left(sString, lPos)
End Function
Beispiel:
Sie haben auf der Form ein WebBrowser-Steuerelement und eine Internetseite geladen. Per Knopfdruck sollen nun alle Linkadressen der Internetseite in einer ListBox angezeigt werden.
Private Sub Command1_Click()
Dim sHTMLText As String
Dim sURL As Variant
Dim I As Integer
' zunächst Seitenquelltext ermitteln
With WebBrowser1.Document
sHTMLText = .documentElement.outerHTML
End With
' jetzt URLs ermitteln
sURL = HTML_GetAllURLs(sHTMLText)
' URLs vorhanden?
If IsArray(sURL) Then
' ListBox mit den URLs füllen
List1.Clear
For I = 0 To UBound(sURL)
List1.AddItem sURL(I)
Next I
End If
End Sub