vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
sevDataGrid - G?nnen Sie Ihrem SQL-Kommando diesen kr?nenden Abschlu?!  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   RSS-Feeds  | Newsletter  | Impressum  | Datenschutz  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2015
 
zurück
Rubrik: HTML/Internet/Netzwerk · Internet / Browser / IE   |   VB-Versionen: VB5, VB630.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 BitzerBewertung:     [ Jetzt bewerten ]Views:  24.200 
www.pda-dev.deSystem:  Win9x, WinNT, Win2k, WinXP, Vista, Win7, Win8, Win10 Beispielprojekt auf CD 

Summer-Special bei Tools & Components!
Gute Laune Sommer bei Tools & Components
Top Summer-Special - Sparen Sie teilweise über 100,- EUR
Alle sev-Entwicklerkomponenten und Komplettpakete jetzt bis zu 25% reduziert!
zum Beispiel:
  • Developer CD nur 455,- EUR statt 569,- EUR
  • sevDTA 2.0 nur 224,30 EUR statt 299,- EUR
  •  
  • vb@rchiv   Vol.6 nur 18,70 EUR statt 24,95 EUR
  • sevCoolbar 3.0 nur 58,70 EUR statt 69,- EUR
  • - Werbung -Und viele weitere Angebote           Aktionspreise nur für kurze Zeit gültig

    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

    Dieser Tipp wurde bereits 24.200 mal aufgerufen.

    Voriger Tipp   |   Zufälliger Tipp   |   Nächster Tipp

    Über diesen Tipp im Forum diskutieren
    Haben Sie Fragen oder Anregungen zu diesem Tipp, können Sie gerne mit anderen darüber in unserem Forum diskutieren.

    Neue Diskussion eröffnen

    nach obenzurück


    Anzeige

    Kauftipp Unser Dauerbrenner!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.
     
       

    Druckansicht Druckansicht Copyright ©2000-2015 vb@rchiv Dieter Otter
    Alle 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.

    Diese Seiten wurden optimiert für eine Bildschirmauflösung von mind. 1280x1024 Pixel