Internet Explorer 4.x and higher exposes Automation interfaces which
allow us to manipulate the external browser window in several ways.
If we want to read URLs and window captions of open IE windows on
the desktop, we can also use a few API functions that locate the Address
text box in the IE window and retrieve the text (URL) currently being displayed there.
Similarly, we can send a URL to the Address window and simulate an Enter
keypress, telling IE to browse to the new URL (which can be a folder on the hard drive or
a WWW site).
The class InetExplorer can be used as follows:
Sub TestURL()
On Error GoTo ErrHandler
Dim clsInet As InetExplorer
Dim i As Integer
Set clsInet = New InetExplorer
With clsInet
.Refresh
For i = 1 To .Count
Debug.Print "URL: " & .ItemURL(i)
Debug.Print "hWnd: " & .ItemhWnd(i)
Debug.Print "Caption: " & .ItemCaption(i)
Debug.Print "-------"
If .ItemCaption(i) = "about:blank" Then
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
The class InetExplorer is:
Option Compare Database
Option Explicit
Option Base 1
Private Type URL_INFO
hWnd As Long
hWndEdit As Long
Caption As String
URL As String
End Type
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
Private Declare Function apiGetClassName Lib "user32" _
Alias "GetClassNameA" _
(ByVal hWnd As Long, _
ByVal lpClassname As String, _
ByVal nMaxCount As Long) _
As Long
Private Declare Function apiGetWindow Lib "user32" _
Alias "GetWindow" _
(ByVal hWnd As Long, _
ByVal wCmd As Long) _
As Long
Private Declare Function apiGetWindowText Lib "user32" _
Alias "GetWindowTextA" _
(ByVal hWnd As Long, _
ByVal lpString As String, _
ByVal cch As Long) _
As Long
Private Declare Function apiGetDesktopWindow Lib "user32" _
Alias "GetDesktopWindow" () _
As Long
Private Declare Function apiGetWindowLong Lib "user32" _
Alias "GetWindowLongA" _
(ByVal hWnd As Long, _
ByVal nIndex As Long) _
As Long
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
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
Private Declare Function apiGetKeyboardState Lib "user32" _
Alias "GetKeyboardState" _
(pbKeyState As Byte) _
As Long
Private Declare Function apiGetVersionEx Lib "Kernel32" _
Alias "GetVersionExA" _
(lpVersionInformation As OSVERSIONINFO) _
As Long
Private Const GW_CHILD = 5
Private Const GW_HWNDNEXT = 2
Private Const GWL_STYLE = (-16)
Private Const WS_VISIBLE = &H10000000
Private Const WM_GETTEXT = &HD
Private Const WM_GETTEXTLENGTH = &HE
Private Const WM_SETTEXT = &HC
Private Const WM_KEYDOWN = &H100
Private Const VK_RETURN = &HD
Private Const VER_PLATFORM_WIN32_WINDOWS = 1
Private Const VER_PLATFORM_WIN32_NT = 2
Private Const MAX_LEN = 255
Private Const mconIE_CLASS = "CabinetWClass"
Private Const IEWND_CLASS_FRAME = "IEFrame"
Private Const mconIE_EDIT = "Edit"
Private Const mconIE_WORKERW = "WorkerW"
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"
Private matURLs() As URL_INFO
Public Sub NavigateTo(Index As Integer, NewURL As String)
On Error GoTo ErrHandler
Dim hWnd As Long
Dim abytkeys(0 To 255) As Byte
hWnd = CLng(fGetURLInfo(Index, 3))
If hWnd > 0 Then
Call apiGetKeyboardState(abytkeys(0))
Call apiSendMessage(hWnd, WM_SETTEXT, 0, _
ByVal CStr(NewURL & vbNullChar))
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
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
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
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()
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
Erase matURLs
intHits = 1
hWnd = apiGetWindow(apiGetDesktopWindow(), _
GW_CHILD)
Do While Not hWnd = 0
lngStyle = apiGetWindowLong(hWnd, GWL_STYLE)
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)
intPos = InStr(1, strCaption, mconCAPTION)
If intPos > 0 Then
strCaption = Left$(strCaption, intPos - 1)
End If
If fIsNT() Then
hWndChild = apiFindWindowEx(hWnd, 0, _
mconIE_WORKERW, vbNullString)
Else
hWndChild = apiFindWindowEx(hWnd, 0, _
mconIE_WORKERA, vbNullString)
End If
If hWndChild > 0 Then
hWndChild = apiFindWindowEx(hWndChild, 0, _
mconIE_REBAR, vbNullString)
End If
If hWndChild > 0 Then
hWndChild = apiFindWindowEx(hWndChild, 0, _
mconIE_COMBOEx, vbNullString)
End If
If hWndChild > 0 Then
hWndChild = apiFindWindowEx(hWndChild, 0, _
mconIE_COMBO, vbNullString)
End If
If hWndChild > 0 Then
hWndChild = apiFindWindowEx(hWndChild, 0, _
mconIE_EDIT, vbNullString)
End If
If hWndChild > 0 Then
lngLen = apiSendMessage(hWndChild, WM_GETTEXTLENGTH, _
0, ByVal 0&)
strURL = Space$(lngLen + 1)
lngLen = apiSendMessage(hWndChild, WM_GETTEXT, _
lngLen + 1, ByVal strURL)
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
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
On Error GoTo ErrHandler
Dim strOut As String
Select Case intType
Case 0:
strOut = CStr(matURLs(intIndex).hWnd)
Case 1:
strOut = matURLs(intIndex).Caption
Case 2:
strOut = matURLs(intIndex).URL
Case 3:
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
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
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
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
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
|