作者：乔山办公网日期：
返回目录：excel表格制作
'准备工作：1.用IE打开百度e799bee5baa6e78988e69d83364
2.调用函数GetIE
'代码搜索标题包含百度的IE窗口，然后控制打开hao123，最后保存为c:\myhtml.txt
Option Explicit
'
' 工程要引用 "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 GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hWnd 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 EnumWindows Lib "user32" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Boolean
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
Dim IEhwnd As Long
Dim IEserver As Long
'
' IEDOMFromhWnd
'
' Returns the IHTMLDocument interface from a WebBrowser window
'
' hWnd - Window handle of the control
'
Function IEDOMFromhWnd() As IHTMLDocument
Dim IID_IHTMLDocument As UUID
Dim hWnd As Long
Dim lRes As Long
Dim lMsg As Long
Dim hr As Long
' Find a child IE server window
EnumWindows AddressOf EnumWindowProc, ByVal 0
If IEhwnd Then EnumChildWindows IEhwnd, AddressOf EnumChildProc, ByVal 0
If IEserver Then hWnd = IEserver Else Exit Function
' 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 Function
Private Function IsIEServerWindow(ByVal hWnd As Long) As Boolean
Dim lRes As Long
Dim sClassName As String
sClassName = GetClsName(hWnd)
IsIEServerWindow = StrComp(sClassName, "Internet Explorer_Server", vbTextCompare) = 0
End Function
'返回窗口类名
Public Function GetClsName(ByVal hWnd As Long) As String
Dim lRes As Long
Dim sClassName As String
sClassName = String$(200, 0)
lRes = GetClassName(hWnd, sClassName, Len(sClassName))
GetClsName = Left$(sClassName, lRes)
End Function
'返回窗口标题
Public Function GetWinTitle(ByVal lhWnd As Long) As String
Dim MyStr As String
MyStr = String(200, Chr$(0))
GetWindowText lhWnd, MyStr, 200
GetWinTitle = Left(MyStr, InStr(MyStr, Chr$(0)) - 1)
End Function
Function EnumWindowProc(ByVal hWnd As Long, ByVal lParam As Long) As Long
Dim sIEtitle As String
sIEtitle = GetWinTitle(hWnd)
If InStr(1, sIEtitle, "百度") Then '搜索标题包含baidu的窗口
IEhwnd = hWnd
Else
EnumWindowProc = 1
End If
End Function
Function EnumChildProc(ByVal hWnd As Long, lParam As Long) As Long
If IsIEServerWindow(hWnd) Then
IEserver = hWnd
Else
EnumChildProc = 1
End If
End Function
Function GetIE() As Long
Dim Doc As IHTMLDocument2
Dim s As String
Set Doc = IEDOMFromhWnd
If Not Doc Is Nothing Then
Doc.url = "http://" '打开网页
Do Until Doc.readyState = "complete"
DoEvents
Loop
s = Doc.body.innerHTML
Open "c:\myhtml.txt" For Output As #1
Print #1, s
Close
End If
End Function
解析源码就可以了，你现在做了多少了？
http://club.excelhome.net/thread-507935-1-1.html
帮你百抄度了个百看看度
Sub cc()
Dim i%, j%, Var$, arr() As String
Path = ThisWorkbook.Path & "\"
f = Dir(Path & "*.htm")
Do While f <> ""
Open Path & f For Input As #1
s = Split(Replace(StrConv(InputB(LOF(1), 1), vbUnicode), Chr(9), ""), ">")
Close #1
For i = 0 To UBound(s)
If InStr(s(i), "</title") Then
Var = "【" & Split(Split(s(i), "<")(0), "【")(1)
j = j + 1
ReDim Preserve arr(1 To 2, 1 To j)
arr(1, j) = "文件名" & j
arr(2, j) = Var
Exit For
End If
Next
f = Dir()
Loop
Sheet1.[a1].Resize(UBound(arr, 2), 2) = WorksheetFunction.Transpose(arr)
End SuB
将以上代码放到工作表中，7a686964616fe59b9ee7ad94362你也看看下这个帖子v
http://club.excelhome.net/thread-518730-2-1.html