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.949
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

Copyright ©2000-2024 vb@rchiv Dieter OtterAlle Rechte vorbehalten.

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.