APIs: Lire et assigner une URL d'Internet Explorer depuis le cod	Author(s) Dev Ashish

    Internet Explorer 4.x et plus récent exposent des interfaces Automation qui nous permettent de manipuler la fenêtre de navigation externe de plusieurs façons.

    Si vous désirez lire le URL (Uniform Ressource Locator) et les titres de fenêtre ouvertes de IE sur votre écran "bureau" (desktop), vous pouvez également utiliser quelques fonctions de l'API qui localiseront la boîte Address dans la fenêtre de IE et ainsi récupéreront le texte (URL) qui s'y trouve présentement affiché.

    De même, on peut envoyer un  URL à ce contrôle et simuler l'enfoncement de la clé Retour de chariot ( Enter ), demandant ainsi à IE de repérer ce nouvel URL (qui peut tout aussi bien être un dossier sur le disque rigide qu'un site Web).

Télécharger InetExplorer.bas

   La classe InetExplorer peut être utilisée comme suit:

'********* Code Start ***********
Sub TestURL()
On Error GoTo ErrHandler
Dim clsInet As InetExplorer
Dim i As Integer

    '   instantiatiation de la classe
    Set clsInet = New InetExplorer
    With clsInet
        '   compléter l'information de la classe avec toutes
        '   les fenêtres actuellement ouvertes par Internet Explorer
        .Refresh
        '   Le vecteur interne est en origine 1
        For i = 1 To .Count
            '   Le URL actuellement affiché par IE
            Debug.Print "URL:  " & .ItemURL(i)
            '   La poignée de la fenêtre  IE 
            Debug.Print "hWnd:  " & .ItemhWnd(i)
            '   Le titre de la fenêtre IE
            Debug.Print "Caption:  " & .ItemCaption(i)
            Debug.Print "-------"
            If .ItemCaption(i) = "about:blank" Then
                '   Si une des pages est actuellement blanche, 
                '   naviguer à une nouvelle page
                '   Puisque plus d'une fenêtre peut avoir le même
                '   titre,  NavigateTo forcera la navigation
                '   à ce nouvel URL sur chacune de ces instnaces
                '   de IE instances séparémment.
                Call .NavigateTo(i, "C:\")
            End If
        Next
    End With
ExitHere:
    Set clsInet = Nothing
    Exit Sub
ErrHandler:
    MsgBox Err.Number & vbCrLf & Err.Description, _
        vbCritical + vbOKOnly, Err.Source
    Resume ExitHere
End Sub
'********* Code End ***********

La classe InetExplorer :

'********* Code Start ***********
Option Compare Database
Option Explicit
Option Base 1

'   UDT (User Defined Type) interne d'une instance de IE
Private Type URL_INFO
    hWnd As Long            '  handle to the IE Window
    hWndEdit As Long      '  handle to the EditBox in the IE Window
    Caption As String       '  Window Title
    URL As String             '  Current URL being browsed
End Type

'   structure contenant la version du système d'exploitation
Private Type OSVERSIONINFO
    dwOSVersionInfoSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatformId As Long
    szCSDVersion As String * 128
End Type

'   retrouve le nom de la classe appartenant à la fenêtre spécifié.
Private Declare Function apiGetClassName Lib "user32" _
    Alias "GetClassNameA" _
    (ByVal hWnd As Long, _
    ByVal lpClassname As String, _
    ByVal nMaxCount As Long) _
    As Long

'   retrouve le hangle de la fenêtre qui a le lien spécifié 
'   Zorder ou owner) à la fenêtre spécifiée.
Private Declare Function apiGetWindow Lib "user32" _
    Alias "GetWindow" _
    (ByVal hWnd As Long, _
    ByVal wCmd As Long) _
    As Long

'   copie le texte du titre de la fenêtre spécifiée (si texte il y a ) dans un tampon
'   S'il s'agit d'un contrôle, le texte du contrôle est copié.
Private Declare Function apiGetWindowText Lib "user32" _
    Alias "GetWindowTextA" _
    (ByVal hWnd As Long, _
    ByVal lpString As String, _
    ByVal cch As Long) _
    As Long

'   retourne un hangle de l'écran-bureau (desktop window).
Private Declare Function apiGetDesktopWindow Lib "user32" _
    Alias "GetDesktopWindow" () _
    As Long

'   retrouve l'information de la fenêtre spécifiée. Cette fonction
'   retourne également la valeur  32-bit (long) à l'offset spécifié dans
'   la mémoire "dédiée à la fenêtre" (extra window memory).
Private Declare Function apiGetWindowLong Lib "user32" _
    Alias "GetWindowLongA" _
    (ByVal hWnd As Long, _
    ByVal nIndex As Long) _
    As Long

'   retrouve le handle de la fenêtre done le nom de la classe et celui de la fenêtre
'   correspond à ceux spécifiés. La recherche commence par celle qui est spécifiée
'   dans le cas de fenêtres filles.
Private Declare Function apiFindWindowEx Lib "user32" _
    Alias "FindWindowExA" _
    (ByVal hWnd1 As Long, _
    ByVal hWnd2 As Long, _
    ByVal lpsz1 As String, _
    ByVal lpsz2 As String) _
    As Long

'   envoie le message à une ou des fenêtres. La fonction ne retourne 
'   pas tant que la fenêtre n'a pas terminé
'   le traitement du message.
Private Declare Function apiSendMessage Lib "user32" _
    Alias "SendMessageA" _
    (ByVal hWnd As Long, _
    ByVal wMsg As Long, _
    ByVal wParam As Long, _
    lParam As Any) _
    As Long

'   copie le statut des 256 clés virtuelles dans le tampon spécifié.
Private Declare Function apiGetKeyboardState Lib "user32" _
    Alias "GetKeyboardState" _
    (pbKeyState As Byte) _
    As Long

'   obtenir l'information relative au système
'   d'exploitation en cours d'utilisation.
Private Declare Function apiGetVersionEx Lib "Kernel32" _
    Alias "GetVersionExA" _
    (lpVersionInformation As OSVERSIONINFO) _
    As Long

'  GetWindow - The retrieved handle identifies the child window at the top of the
'   Z order if the specified window is a parent window; otherwise, the retrieved
'   handle is NULL. The function examines only child windows of the specified
'   window. It does not examine descendant windows.
Private Const GW_CHILD = 5

'   GetWindow - The retrieved handle identifies the window below the specified
'   window in the Z order. If the specified window is a topmost window,
'   the handle identifies the topmost window below the specified window.
'   If the specified window is a top-level window, the handle identifies the
'   top-level window below the specified window. If the specified window is
'   a child window, the handle identifies the sibling window below the
'   specified window.
Private Const GW_HWNDNEXT = 2

'   GetWindowLong - Retrieves the window styles.
Private Const GWL_STYLE = (-16)

'   //Window Styles
Private Const WS_VISIBLE = &H10000000   'Visible

'   //Window messages
'   An application sends a WM_GETTEXT message to copy the text that
'   corresponds to a window into a buffer provided by the caller.
Private Const WM_GETTEXT = &HD

'   An application sends a WM_GETTEXTLENGTH message to determine
'   the length, in characters, of the text associated with a window.
Private Const WM_GETTEXTLENGTH = &HE

'   An application sends a WM_SETTEXT message to set the text of a window.
Private Const WM_SETTEXT = &HC

'   The WM_KEYDOWN message is posted to the window with the keyboard
'   focus when a nonsystem key is pressed. A nonsystem key is a key
'   that is pressed when the ALT key is not pressed.
Private Const WM_KEYDOWN = &H100

'   //Keyboard constants
Private Const VK_RETURN = &HD

'   //GetVersionEx constants
Private Const VER_PLATFORM_WIN32_WINDOWS = 1
Private Const VER_PLATFORM_WIN32_NT = 2

Private Const MAX_LEN = 255

'   various IE Windows (controls), mconIE_CLASS
'   is the main IE window, the rest are it's children
Private Const mconIE_CLASS = "CabinetWClass"
Private Const IEWND_CLASS_FRAME = "IEFrame"
Private Const mconIE_EDIT = "Edit"
Private Const mconIE_WORKERW = "Worker"
Private Const mconIE_WORKERA = "WorkerA"
Private Const mconIE_REBAR = "ReBarWindow32"
Private Const mconIE_COMBO = "ComboBox"
Private Const mconIE_COMBOEx = "ComboBoxEx32"
Private Const mconCAPTION = " - Microsoft Internet Explorer"

'   internal array to hold IE information
Private matURLs() As URL_INFO

Public Sub NavigateTo(Index As Integer, NewURL As String)
'   Uses SendMessage to force an IE window with the hWnd
'   at dimension Index, navigate to a new URL
'
On Error GoTo ErrHandler
Dim hWnd As Long
Dim abytkeys(0 To 255) As Byte
    
    '   Retrieve the handle to the EditBox
    hWnd = CLng(fGetURLInfo(Index, 3))
    If hWnd > 0 Then
        '   Get the current state of the keyboard
        Call apiGetKeyboardState(abytkeys(0))
        '   send the new URL as the text for the editbox
        Call apiSendMessage(hWnd, WM_SETTEXT, 0, _
                        ByVal CStr(NewURL & vbNullChar))
        '   simulate Enter keypress to force IE to
        '   navigate to the new url
        Call apiSendMessage(hWnd, WM_KEYDOWN, VK_RETURN, _
                        abytkeys(VK_RETURN))
    End If
ExitHere:
    Exit Sub
ErrHandler:
    With Err
        .Raise .Number, "InetExplorer.NavigateTo", .Description, _
                    .HelpFile, .HelpContext
    End With
    Resume ExitHere
End Sub

Public Property Get ItemhWnd(Index As Integer) As Long
'   Returns the Handle of a Window from dimension Index
'   of local array
'
On Error GoTo ErrHandler
    ItemhWnd = CLng(fGetURLInfo(Index, 0))
ExitHere:
    Exit Property
ErrHandler:
    With Err
        .Raise .Number, "InetExplorer::ItemhWnd", .Description, _
                    .HelpFile, .HelpContext
    End With
    Resume ExitHere
End Property

Public Property Get ItemCaption(Index As Integer) As String
'   Returns the caption of a Window from dimension Index
'   of local array
'
On Error GoTo ErrHandler
    ItemCaption = fGetURLInfo(Index, 1)
ExitHere:
    Exit Property
ErrHandler:
    With Err
        .Raise .Number, "InetExplorer::ItemCaption", .Description, _
                    .HelpFile, .HelpContext
    End With
    Resume ExitHere
End Property

Public Property Get ItemURL(Index As Integer) As String
'   Returns the URL of a Window from dimension Index
'   of local array
'
On Error GoTo ErrHandler
    ItemURL = fGetURLInfo(Index, 2)
ExitHere:
    Exit Property
ErrHandler:
    With Err
        .Raise .Number, "InetExplorer::ItemURL", .Description, _
                    .HelpFile, .HelpContext
    End With
    Resume ExitHere
End Property

Public Sub Refresh()
'   Populates the internal array with IE Window information
'
On Error GoTo ErrHandler
Dim strCaption As String, lngLen As Long
Dim strClass As String, strURL As String
Dim hWnd As Long, lngStyle As Long
Dim hWndChild As Long, intHits As Integer
Dim intPos As Integer

    '   Since we are using ReDim Preserve afterwards,
    '   erase the array
    Erase matURLs
    '   Option Base is set to 1
    intHits = 1
    
    '   Start with the first child of the Desktop window
    hWnd = apiGetWindow(apiGetDesktopWindow(), _
                    GW_CHILD)
    '   Enumerate all open windows
    Do While Not hWnd = 0
        lngStyle = apiGetWindowLong(hWnd, GWL_STYLE)
        '   if the window is visible
        If lngStyle And WS_VISIBLE Then
            strClass = fGetClassName(hWnd)
            '   if the class name belongs to IE
            If strClass = mconIE_CLASS Or _
                    strClass = IEWND_CLASS_FRAME Then
                strCaption = fGetCaption(hWnd)
                '   trim out the trailing mconCaption
                intPos = InStr(1, strCaption, mconCAPTION)
                If intPos > 0 Then
                    strCaption = Left$(strCaption, intPos - 1)
                End If
                '   Find the first worker class child of the IE window
                '   For NT, use Unicode version
                If fIsNT() Then
                    hWndChild = apiFindWindowEx(hWnd, 0, _
                                                mconIE_WORKERW, vbNullString)
                Else
                    hWndChild = apiFindWindowEx(hWnd, 0, _
                                                mconIE_WORKERA, vbNullString)
                End If
                
                If hWndChild > 0 Then
                    '   Rebar is child of Worker  window
                    hWndChild = apiFindWindowEx(hWndChild, 0, _
                                                mconIE_REBAR, vbNullString)
                End If
                If hWndChild > 0 Then
                    '   ComboboxEx is child of Rebar window
                    hWndChild = apiFindWindowEx(hWndChild, 0, _
                                                mconIE_COMBOEx, vbNullString)
                End If
                If hWndChild > 0 Then
                    '   ComboBox is child of ComboBoxEx  Window
                    hWndChild = apiFindWindowEx(hWndChild, 0, _
                                                mconIE_COMBO, vbNullString)
                End If
                If hWndChild > 0 Then
                    '   Edit class is child of ComboBox  window
                    hWndChild = apiFindWindowEx(hWndChild, 0, _
                                                mconIE_EDIT, vbNullString)
                End If
                If hWndChild > 0 Then
                    '   Get the length of the URL in Editbox
                    lngLen = apiSendMessage(hWndChild, WM_GETTEXTLENGTH, _
                                    0, ByVal 0&)
                    strURL = Space$(lngLen + 1)
                    '   Get the URL itself
                    lngLen = apiSendMessage(hWndChild, WM_GETTEXT, _
                                            lngLen + 1, ByVal strURL)
                    '   store the entry
                    ReDim Preserve matURLs(intHits)
                    With matURLs(intHits)
                        .Caption = strCaption
                        .hWnd = hWnd
                        .URL = Left$(strURL, lngLen)
                        .hWndEdit = hWndChild
                    End With
                    intHits = intHits + 1
                End If
            End If
        End If
        '   move on to the next window
        hWnd = apiGetWindow(hWnd, GW_HWNDNEXT)
    Loop
        
ExitHere:
    Exit Sub
ErrHandler:
    With Err
        .Raise .Number, "InetExplorer::Refresh", .Description, .HelpFile, .HelpContext
    End With
    Resume ExitHere
End Sub

Public Property Get Count() As Integer
'   Returns count of open IE windows
'
Dim intCount As Integer
    On Error Resume Next
    intCount = UBound(matURLs)
    If Err Then
        intCount = 0
    Else
        Count = intCount
    End If
End Property

Private Function fGetURLInfo(intIndex As Integer, intType As Integer) As String
'   Returns specific information about an IE window
'
On Error GoTo ErrHandler
Dim strOut As String

    Select Case intType
        Case 0:     'hWnd
            strOut = CStr(matURLs(intIndex).hWnd)
        Case 1:     'Caption
            strOut = matURLs(intIndex).Caption
        Case 2:     'URL
            strOut = matURLs(intIndex).URL
        Case 3:     'EditBox's hWnd
            strOut = CStr(matURLs(intIndex).hWndEdit)
    End Select
    fGetURLInfo = strOut
ExitHere:
    Exit Function
ErrHandler:
    fGetURLInfo = vbNullString
    Resume ExitHere
End Function

Private Function fGetClassName(hWnd As Long) As String
'   Returns the classname of a Window
'
Dim strBuffer As String
Dim lngCount As Long
    strBuffer = String$(MAX_LEN + 1, 0)
    lngCount = apiGetClassName(hWnd, strBuffer, MAX_LEN)
    If lngCount > 0 Then fGetClassName = Left$(strBuffer, lngCount)
End Function

Private Function fGetCaption(hWnd As Long) As String
'   Returns the caption of a Window
'
Dim strBuffer As String
Dim lngCount As Long
    strBuffer = String$(MAX_LEN + 1, 0)
    lngCount = apiGetWindowText(hWnd, strBuffer, MAX_LEN)
    If lngCount > 0 Then fGetCaption = Left$(strBuffer, lngCount)
End Function

Private Function fIsNT() As Boolean
'   Returns true if current platform is WiNNT
'
Dim tOSInfo  As OSVERSIONINFO
    tOSInfo.dwOSVersionInfoSize = Len(tOSInfo)
    Call apiGetVersionEx(tOSInfo)
    fIsNT = (tOSInfo.dwPlatformId = VER_PLATFORM_WIN32_NT)
End Function

Private Function fIsWin9x() As Boolean
'   Returns true if current platform is Win95 or Win98
'
Dim tOSInfo  As OSVERSIONINFO
    tOSInfo.dwOSVersionInfoSize = Len(tOSInfo)
    Call apiGetVersionEx(tOSInfo)
    fIsWin9x = (tOSInfo.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS)
End Function

Private Sub Class_Terminate()
    '   do cleanup here
    On Error Resume Next
    Erase matURLs
End Sub
'********* Code End  ***********