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 Dieser Tipp wurde bereits 40.451 mal aufgerufen. Voriger Tipp | Zufälliger Tipp | Nächster Tipp
Anzeige
Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv Vol.6 (einschl. Beispielprojekt!) Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv! - nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten - Symbol-Galerie mit mehr als 3.200 Icons im modernen Look Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m. |
vb@rchiv CD Vol.6 Geballtes Wissen aus mehr als 8 Jahren vb@rchiv! Online-Update-Funktion Entwickler-Vollversionen u.v.m. Tipp des Monats März 2024 Dieter Otter UTF-8 Konvertierung von Dateien und Strings VB6 selbst verfügt über keine Funktionen zur UTF-8 Konvertierung von Daten. Mit Hilfe des ADODB.Stream-Objekts lassen sich diese fehlenden Funktionen aber schnell nachrüsten. Neu! sevDTA 3.0 Pro SEPA mit Kontonummernprüfung Erstellen von SEPA-Dateien mit integriertem BIC-Verzeichnis und Konto- nummern-Prüfverfahren, so dass ungültige Bankdaten bereits im Vorfeld ermittelt werden können. |
||||||||||||||||
Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein. |