Url aller Browserfenster auslesen

'Alle momentan besuchten URL´s auslesen
'vb -Versionen: VB5 , VB6
'Betriebssystem:  Win9x , WinNT, Win2000, WinME, WinXP
'Autor: Frank Bitzer Homepage: <a href="http://www.pda-dev.de/">http://www.pda-dev.de/</a>
'Datum:  30.12.2003  Download:  -
'Sprache:  deutsch   Views:  5503
'Beschreibung
'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
'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.
Sub probe()
Dim sViewedURL As String
sViewedURL = GetURLList(Me)
MsgBox "Folgende Webaddressen werden gerade besucht: " & _
vbCrLf & sViewedURL
End Sub
'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, <a href="http://www.programatrix.de">http://www.programatrix.de</a>
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