引用 Microsoft Internet Controls Microsoft Html Object Library
Private Type UUID Data1 As Long Data2 As Integer Data3 As Integer Data4(0 To 7) As Byte End Type
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 EnumChildWindows Lib "user32" ( _ ByVal hWndParent As Long, _ ByVal lpEnumFunc As Long, _ lParam As Long) As Long
Private Declare Function RegisterWindowMessage Lib "user32" _ Alias "RegisterWindowMessageA" ( _ ByVal lpString As String) As Long
Private Declare Function SendMessageTimeout Lib "user32" _ Alias "SendMessageTimeoutA" ( _ ByVal hwnd As Long, _ ByVal msg As Long, _ ByVal wParam As Long, _ lParam As Any, _ ByVal fuFlags As Long, _ ByVal uTimeout As Long, _ lpdwResult As Long) As Long
Private Const SMTO_ABORTIFHUNG = &H2
Private Declare Function ObjectFromLresult Lib "oleacc" ( _ ByVal lResult As Long, _ riid As UUID, _ ByVal wParam As Long, _ ppvObject As Any) As Long
Private Declare Function FindWindow Lib "user32" _ Alias "FindWindowA" ( _ ByVal lpClassName As String, _ ByVal lpWindowName As String) As LongFunction IEDOMFromhWnd(ByVal hwnd As Long) As IHTMLDocument Dim IID_IHTMLDocument As UUID Dim hWndChild As Long Dim lRes As Long Dim lMsg As Long Dim hr As Long
If hwnd <> 0 Then If Not IsIEServerWindow(hwnd) Then ' Find a child IE server window EnumChildWindows hwnd, AddressOf EnumChildProc, hwnd End If
If hwnd <> 0 Then ' Register the message lMsg = RegisterWindowMessage("WM_HTML_GETOBJECT") ' Get the object pointer Call SendMessageTimeout(hwnd, lMsg, 0, 0, _ SMTO_ABORTIFHUNG, 1000, lRes) If lRes Then ' Initialize the interface ID With IID_IHTMLDocument .Data1 = &H626FC520 .Data2 = &HA41E .Data3 = &H11CF .Data4(0) = &HA7 .Data4(1) = &H31 .Data4(2) = &H0 .Data4(3) = &HA0 .Data4(4) = &HC9 .Data4(5) = &H8 .Data4(6) = &H26 .Data4(7) = &H37 End With ' Get the object from lRes hr = ObjectFromLresult(lRes, IID_IHTMLDocument, _ 0, IEDOMFromhWnd) End If End If End If End FunctionPrivate Function IsIEServerWindow(ByVal hwnd As Long) As Boolean Dim lRes As Long Dim sClassName As String
' Initialize the buffer sClassName = String$(100, 0) ' Get the window class name lRes = GetClassName(hwnd, sClassName, Len(sClassName)) sClassName = Left$(sClassName, lRes) IsIEServerWindow = StrComp(sClassName, _ "Internet Explorer_Server", _ vbTextCompare) = 0 End Function
' ' Copy this function to a .bas module ' Function EnumChildProc(ByVal hwnd As Long, lParam As Long) As Long If IsIEServerWindow(hwnd) Then lParam = hwnd Else EnumChildProc = 1 End If End Function
Microsoft Internet Controls
Microsoft Html Object Library
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
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 EnumChildWindows Lib "user32" ( _
ByVal hWndParent As Long, _
ByVal lpEnumFunc As Long, _
lParam As Long) As Long
Private Declare Function RegisterWindowMessage Lib "user32" _
Alias "RegisterWindowMessageA" ( _
ByVal lpString As String) As Long
Private Declare Function SendMessageTimeout Lib "user32" _
Alias "SendMessageTimeoutA" ( _
ByVal hwnd As Long, _
ByVal msg As Long, _
ByVal wParam As Long, _
lParam As Any, _
ByVal fuFlags As Long, _
ByVal uTimeout As Long, _
lpdwResult As Long) As Long
Private Const SMTO_ABORTIFHUNG = &H2
Private Declare Function ObjectFromLresult Lib "oleacc" ( _
ByVal lResult As Long, _
riid As UUID, _
ByVal wParam As Long, _
ppvObject As Any) As Long
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As LongFunction IEDOMFromhWnd(ByVal hwnd As Long) As IHTMLDocument
Dim IID_IHTMLDocument As UUID
Dim hWndChild As Long
Dim lRes As Long
Dim lMsg As Long
Dim hr As Long
If hwnd <> 0 Then
If Not IsIEServerWindow(hwnd) Then
' Find a child IE server window
EnumChildWindows hwnd, AddressOf EnumChildProc, hwnd
End If
If hwnd <> 0 Then
' Register the message
lMsg = RegisterWindowMessage("WM_HTML_GETOBJECT")
' Get the object pointer
Call SendMessageTimeout(hwnd, lMsg, 0, 0, _
SMTO_ABORTIFHUNG, 1000, lRes)
If lRes Then
' Initialize the interface ID
With IID_IHTMLDocument
.Data1 = &H626FC520
.Data2 = &HA41E
.Data3 = &H11CF
.Data4(0) = &HA7
.Data4(1) = &H31
.Data4(2) = &H0
.Data4(3) = &HA0
.Data4(4) = &HC9
.Data4(5) = &H8
.Data4(6) = &H26
.Data4(7) = &H37
End With
' Get the object from lRes
hr = ObjectFromLresult(lRes, IID_IHTMLDocument, _
0, IEDOMFromhWnd)
End If
End If
End If
End FunctionPrivate Function IsIEServerWindow(ByVal hwnd As Long) As Boolean
Dim lRes As Long
Dim sClassName As String
' Initialize the buffer
sClassName = String$(100, 0)
' Get the window class name
lRes = GetClassName(hwnd, sClassName, Len(sClassName))
sClassName = Left$(sClassName, lRes)
IsIEServerWindow = StrComp(sClassName, _
"Internet Explorer_Server", _
vbTextCompare) = 0
End Function
'
' Copy this function to a .bas module
'
Function EnumChildProc(ByVal hwnd As Long, lParam As Long) As Long
If IsIEServerWindow(hwnd) Then
lParam = hwnd
Else
EnumChildProc = 1
End If
End Function
取webbrowser句柄
得到网页的document对象剩下来就很简单了.