Rubrik: HTML/Internet/Netzwerk · Internet / Browser / IE | VB-Versionen: VB5, VB6 | 30.12.03 |
Alle momentan besuchten URL´s auslesen Liefert eine Liste aller momentan mit dem Internet Explorer oder Netscape Navigator betrachteten URL's | ||
Autor: Frank Bitzer | Bewertung: | Views: 32.959 |
www.pda-dev.de | System: Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11 | Beispielprojekt auf CD |
Wie man die URL der gerade besuchten Website mit DDE sehr einfach ermitteln kann, lässt sich bereits mit diesem Tipp entnehmen. Das hat aber zwei entscheidende Nachteile:
- Erstens ist DDE nicht sehr schnell und recht fehleranfällig. Auch Microsoft selbst scheint davon nicht mehr viel zu halten. In VB.NET beispielsweise wird DDE bereits nicht mehr unterstützt.
- Zweitens stösst man spätestens dann an die Grenzen, wenn mehrere Browserfenster gleichzeitig geöffnet sind und man ALLE geöffneten URL's abfragen möchte. In diesem Fall hilft folgender Tipp, der sich anstelle von DDE schamlos der Windows-API bedient ;).
Das Prinzip dahinter ist folgendes: es werden der Reihe nach alle Top-Level-Fenster abgefragt, ob es sich dabei um Browserfenster handelt.
Erkannt werden Opera, Netscape und Mozilla Firefox daran, dass sie einen bestimmten Fenstertitel besitzen, sowie der Microsoft Internet Explorer und darauf basierende Browser dadurch, dass ihr Klassenname "IEFrame" lautet. Wird ein solches Browserfenster gefunden, dann werden solange alle Child-Objekte durchsucht, bis eines vom Typ "Edit" gefunden wurde - dies ist nämlich dann das Feld, in dem die URL steht. Dessen Text können wir nun via SendMessage und WM_GETTEXT auslesen
Update vom 10.02.05:
Da inwzischen auch Firefox als Browser weit verbreitet ist, wurde der Tipp erweitert, so dass sich auch damit besuchte Seiten auflisten lassen. Dies funktioniert allerdings nur mittels DDE und daher mit den oben beschriebenen Nachteilen. Grund dafür ist, dass Mozilla Firefox keine benannten Fensterklassen benutzt und es daher auf beschriebene Art und Weise unmöglich ist, herauszufinden, in welchem Feld die richtige URL steht.
Nun zum Quellcode:
Zuerst mal die Deklartionen... (unbedingt in ein Modul einfügen)
Option Explicit ' Verweis auf ein Formular, das eine Textbox "txtDDE" enthält! Private CallingForm As Form ' Benötigte API-Deklarationen Private Declare Function EnumWindows Lib "user32" ( _ ByVal lpEnumFunc As Any, _ ByVal lParam As Long) As Long Private Declare Function GetWindowText Lib "user32" _ Alias "GetWindowTextA" ( _ ByVal hwnd As Long, _ ByVal lpString As String, _ ByVal cch As Long) As Long Private Declare Function GetWindow Lib "user32" ( _ ByVal hwnd As Long, _ ByVal wCmd As Long) As Long Private Declare Function GetClassName Lib "user32" _ Alias "GetClassNameA" ( _ ByVal hwnd As Long, _ ByVal lpClassName As String, _ ByVal nMaxCount As Long) As Long Private Declare Function SendMessage Lib "user32" _ Alias "SendMessageA" ( _ ByVal hwnd As Long, _ ByVal wMsg As Long, _ ByVal wParam As Long, _ lParam As Any) As Long Private Declare Function IsValidURL Lib "URLMON.DLL" ( _ ByVal pbc As Long, _ ByVal szURL As String, _ ByVal dwReserved As Long) As Long Private Const WM_GETTEXT = &HD Private Const WM_GETTEXTLENGTH = &HE Private Const GW_CHILD = 5 Private Const GW_HWNDNEXT = 2 ' String, der mit den einzelnen URL's ' gefüllt wird Private sURLList As String
So, nun kommen wir gleich zur Hauptfunktion. Diese deklarieren als "Public", damit wir später von ausserhalb des Moduls darauf zugreifen können. Der Rückgabewert ist ein String, der die einzelnen URL's, getrennt durch Kommas, enthält. Mit noch etwas Feintuning könnte man natürlich auch ein Array zurückgeben, aber das soll ja nicht der Sinn dieses Tipps sein...
' Hilfsfunktion Public Function IsGoodURL(ByVal sURL As String) As Boolean sURL = StrConv(sURL, vbUnicode) IsGoodURL = (IsValidURL(ByVal 0&, sURL, 0) = 0) End Function
Public Function GetURLList(frm As Form) As String sURLList = "" ' Verweis auf Formular, das die Textbox "txtDDE" enthält Set CallingForm = frm ' Alle geöffneten Windows durchlaufen EnumWindows AddressOf EnumerateProc, 0 If Len(sURLList) > 0 Then ' Abtrennen des führenden "," sURLList = Mid(sURLList, 2) End If GetURLList = sURLList sURLList = "" End Function
Die Function "EnumerateProc" hat die Aufgabe sich durch alle laufenden Top-Level Windows zu kämpfen...
Private Function EnumerateProc( _ ByVal app_hwnd As Long, _ ByVal lParam As Long) As Boolean Dim buf As String * 1024 Dim title As String Dim length As Long ' Fenstertitel auslesen. length = GetWindowText(app_hwnd, buf, Len(buf)) title = Left$(buf, length) ' zusätzlich Name der Fensterklasse bestimmen ' ist es ein Internet Explorer Fenster, so lautet der Klassenname "IEFrame" length = 256 buf = Space$(length - 1) length = GetClassName(app_hwnd, buf, length) buf = Left$(buf, length) ' enthält der Fenstertitel den Namen eines Browsers? ' 1. Internet Explorer (und darauf basierende Browser), Opera, Netscape If InStr(1, title, "Opera", 1) Or _ InStr(1, title, "Netscape", 1) Or _ Trim(buf) = "IEFrame" Then ' Juhuu, ein Browser wurde entdeckt - die URL ' kann (wahrscheinlich) ausgelesen werden ' das Ergebnis des Auslesens wird zur Liste hinzugefügt sURLList = sURLList & "," & getURL(app_hwnd) ' Firefox, Mozilla: Titel des Fensters überprüfen und ggf. URL mit DDE auslesen ElseIf Right$(title, 7) = "Firefox" Then sURLList = sURLList & "," & GetURLFromMozilla("Firefox") ElseIf InStr(1, title, "Mozilla", 1) Then sURLList = sURLList & "," & GetURLFromMozilla("Mozilla") End If ' Weitersuchen... EnumerateProc = 1 End Function
Die Funktion zum Ermitteln der Child-Objekte, bis eine Edit-Klasse gefunden wird, sieht so aus:
Private Function getURL(window_hwnd As Long) As String Dim txt As String Dim buf As String Dim buflen As Long Dim child_hwnd As Long Dim children() As Long Dim num_children As Integer Dim i As Integer Dim sURL As String ' Klassennamen ermitteln --> wir wollen "Edit" buflen = 256 buf = Space$(buflen - 1) buflen = GetClassName(window_hwnd, buf, buflen) buf = Left$(buf, buflen) ' Edit-Klasse gefunden ? If buf = "Edit" Then ' ja, d.h. wir brauchen nur noch den ' Text auslesen sURL = ReadText(window_hwnd) If IsGoodURL(sURL) Then getURL = sURL Exit Function End If End If ' kein Edit-Objekt oder ungültige URL :( ' wir müssen die (weiteren) Childs ' durchsuchen (rekursiv) num_children = 0 child_hwnd = GetWindow(window_hwnd, GW_CHILD) Do While child_hwnd <> 0 num_children = num_children + 1 ReDim Preserve children(1 To num_children) children(num_children) = child_hwnd child_hwnd = GetWindow(child_hwnd, GW_HWNDNEXT) Loop ' wir untersuchen wiederrum die Child's, ' ob sie vom Typ Edit sind For i = 1 To num_children txt = getURL(children(i)) If txt <> "" Then Exit For Next i getURL = txt End Function
Jetzt fehlt uns nur noch die Funktion, die den Text ausliest, wenn wir auf ein Edit-Objekt stoßen. Voilà:
Private Function ReadText(window_hwnd As Long) As String Dim txtlen As Long Dim txt As String ReadText = "" If window_hwnd = 0 Then Exit Function txtlen = SendMessage(window_hwnd, WM_GETTEXTLENGTH, 0, 0) If txtlen = 0 Then Exit Function txtlen = txtlen + 1 txt = Space$(txtlen) txtlen = SendMessage(window_hwnd, WM_GETTEXT, txtlen, ByVal txt) ReadText = Left$(txt, txtlen) End Function
' Funktion zum Auslesen der URL von Mozilla Browsern mittels DDE ' Autor: Jörg von Busekist, http://www.programatrix.de Private Function GetURLFromMozilla(ByVal Browser As String) As String Dim TheUrl As String Dim i As Integer Dim CC As Long, parms(3) As String, quoting As Boolean Dim thisParm As Integer, p As Long, c As Byte On Error GoTo GUBErrHandler CallingForm.txtDDE.LinkTopic = Browser & "|WWW_GetWindowInfo" ' tell Browser to send us name and title of the last active window or frame CallingForm.txtDDE.LinkItem = &HFFFFFFFF CallingForm.txtDDE.LinkMode = 2 CallingForm.txtDDE.LinkRequest ' parse out info given to us by the Browser in callinform.txtDDE.Text; should be in the form ' "URL","Page title","FrameName" thisParm = 1 quoting = False For i = 1 To Len(CallingForm.txtDDE) c = Asc(Mid(CallingForm.txtDDE, i, 1)) Select Case c Case 34 ' quotation mark quoting = Not quoting Case 44 ' comma If Not quoting Then thisParm = thisParm + 1 If thisParm > 3 Then Exit For End If Case Else If quoting Then parms(thisParm) = parms(thisParm) & Chr(c) End If End Select Next i GetURLFromMozilla = parms(1) CallingForm.txtDDE.Text = "" Exit Function GUBErrHandler: ' skip process if any errors occur, i.e., Netscape did not respond to DDE initiate event GetURLFromMozilla = "" On Error GoTo 0 End Function
Das war's dann auch schon.
Beim Aufruf der Funktion muss unbedingt der Verweis auf ein Formular übergeben werden, dass eine TextBox mit dem Namen "txtDDE" enthält. Die Textbox ist für den DDE erforderlich und kann auch unsichtbar sein.
Dim sViewedURL As String sViewedURL = GetURLList(Me) MsgBox "Folgende Webaddressen werden gerade besucht: " & _ vbCrLf & sViewedURL