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:
Das Prinzip dahinter ist folgendes: es werden der Reihe nach alle Top-Level-Fenster abgefragt, ob es sich dabei um Browserfenster handelt. Update vom 10.02.05: Nun zum Quellcode: 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. Dim sViewedURL As String sViewedURL = GetURLList(Me) MsgBox "Folgende Webaddressen werden gerade besucht: " & _ vbCrLf & sViewedURL Dieser Tipp wurde bereits 32.958 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. |
sevISDN 1.0 Überwachung aller eingehender Anrufe! Die DLL erkennt alle über die CAPI-Schnittstelle eingehenden Anrufe und teilt Ihnen sogar mit, aus welchem Ortsbereich der Anruf stammt. Weitere Highlights: Online-Rufident, Erkennung der Anrufbehandlung u.v.m. Tipp des Monats April 2024 Skyfloy Chart von Microsoft und dazu noch gratis Tutorial für Microsoft Chart Controls für Microsoft .NET Framework 3.5 TOP! Unser Nr. 1 Neu! sevDataGrid 3.0 Mehrspaltige Listen, mit oder ohne DB-Anbindung. Autom. Sortierung, Editieren von Spalteninhalten oder das interaktive Hinzufügen von Datenzeilen sind ebenso möglich wie das Erstellen eines Web-Reports. |
||||||||||||||||
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. |