klappt nicht bei Firefox :-(
09.04.2008 13:44:00
Reinhard
Hallo Micha,
ich habe den VB-Code aber leider nicht zum richtigen Funktionieren gebracht.
IE-Browser-Fenster werden korrekt ausgelesen, aber bei Firefox klappt nix denn der Code geht bei
der Funktion GetURLFromMozilla bei
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
immer in die Fehlerroutine bei jedem Firefox-Fenster (Browser="Firefox"), denn LinkTopic, LinkItem usw. gibt es wohl in VBA nicht.
Dafür gibt es wohl etwas entsprechendes wie DDEInitiate, DDEExecute usw., was auch in der Vba-Hilfe
beschrieben wird.
Aber ich kriege es leider nicht hin, dies von VB nach Vba umzusetzen :-(
Eine Beispieldatei mit nachfolgendem Code: https://www.herber.de/bbs/user/51373.xls
Gruß
Reinhard
Folgender Code stammt von http://www.vbarchiv.net/tipps/details.php?id=937
und war für VB.
Ich habe eine Userform (Userform1) angelegt, mir einer TextBox namens txtDDE mit folgendem Code:
Private Sub UserForm_Initialize()
Dim sViewedURL As String
sViewedURL = GetURLList(Me)
MsgBox "Folgende Webaddressen werden gerade besucht: " & vbCrLf & sViewedURL
End Sub
und 2 Verweise im Code auf "Form" auf "Userform" geändert.
*******************************************************************************
'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
Private CallingForm As UserForm
' 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
Sub Starten()
UserForm1.Show 0
End Sub
Public Function GetURLList(frm As UserForm) 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 Len(title) > 0 Then MsgBox title
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
'CallingForm.txtDDE.DDEInitiate Browser & "|WWW_GetWindowInfo", txtDDE
CallingForm.txtDDE.DDEInitiate Browser, txtDDE
' deutsch englisch
'DDEKanalÖffnen DDEInitiate
'DDEAusführen DDEExecute
'DDEKanalSchliessen DDETerminate
'DDEAbfragen DDERequest
'DDESenden DDEPoke
'VISUAL BASIC 3.0:
'engl.
'LinkTopic, LinkMode props
'LinkExecute Method
'LinkMode prop
'LinkItem prop, LinkRequest method
'LinkItem prop, LinkPoke method
' 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
MsgBox "Fehler"
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.
' Beim nachstehenden, komisch keine Sub drumrum, muß wahrscheinlich in die UF
'Dim sViewedURL As String
'sViewedURL = GetURLList(Me)
'MsgBox "Folgende Webaddressen werden gerade besucht: " & _
' vbCrLf & sViewedURL