Sub UseWebBrowser() UseWebBrowser() Cells.Clear Dim sURL As String 'Dim IE As New InternetExplorer Dim hDoc 'As New MSHTML.HTMLDocument Dim myWeb '設定查尋網頁 sURL = "http://www.dbmaker.com.tw/stock/cgihistory.cgi?id=1101&begin=2007&end=2100" '使用ActiveX-Webrowser讀網頁 '裝入網址並顯示在activex元件內 With UserForm1 Set myWeb = .WebBrowser1 myWeb.navigate (sURL) Do While myWeb.ReadyState <> READYSTATE_COMPLETE '等待網頁loading完成 DoEvents Loop '列出網頁中的資料 Set hDoc = myWeb.Document '引用 Document 對象 Call ListTableinnertext(hDoc) 'WebBrowser1.Quit End With Set hDoc = Nothing Set myWeb = Nothing UserForm1.Show 0 End Sub
Sub ListTableinnertext() ListTableinnertext(oDoc) '分析html Dim DocElemsCnt As Integer Dim Tbl As Object Dim rCol As Integer For DocElemsCnt = 0 To oDoc.all.Length - 1 'tagName:獲取對象的標籤名稱。 '標題 If oDoc.all.Item(DocElemsCnt).tagName = "P" Then Set Tbl = oDoc.all.Item(DocElemsCnt) Sheets(1).Range("A1").Value = Tbl.previousSibling.data End If If oDoc.all.Item(DocElemsCnt).tagName = "TABLE" Then Set Tbl = oDoc.all.Item(DocElemsCnt) '裝入整個項目 If Tbl.Rows.Length > 10 Then 'Tbl.Rows.Length:取得TABLE(表格)的列數 For RwLen = 0 To Tbl.Rows.Length - 1 '已知表格資料共有六欄 Sheets(1).Range("A3").Offset(RwLen, 0).Value = Tbl.Rows(RwLen).Cells(0).innerText Sheets(1).Range("B3").Offset(RwLen, 0).Value = Tbl.Rows(RwLen).Cells(1).innerText Sheets(1).Range("C3").Offset(RwLen, 0).Value = Tbl.Rows(RwLen).Cells(2).innerText Sheets(1).Range("D3").Offset(RwLen, 0).Value = Tbl.Rows(RwLen).Cells(3).innerText Sheets(1).Range("E3").Offset(RwLen, 0).Value = Tbl.Rows(RwLen).Cells(4).innerText Sheets(1).Range("F3").Offset(RwLen, 0).Value = Tbl.Rows(RwLen).Cells(5).innerText Next RwLen End If End If Next DocElemsCnt End Sub
範例二:用IE讀取網頁表格
Option Explicit Dim myData() As String Sub IeApp() IeApp() Dim myIe As Object Dim myHtmDoc As Object Set myIe = CreateObject("InternetExplorer.Application") '開啟ie 'Dim IE As New InternetExplorer Dim DocElemsCnt As Long Dim myTable As Object Dim myTableRow As Long, myTableCell As Long Dim RowLen As Integer, CellLen As Integer Dim StartTime As Date, EndTime As Date Dim myRange As Object Application.DisplayStatusBar = True Application.ScreenUpdating = False Sheets(1).Cells = "" Application.StatusBar = "網路連線中請稍候...." StartTime = Timer myIe.navigate "http://www.dbmaker.com.tw/stock/cgihistory.cgi?id=1101&begin=2007&end=2100" myIe.Visible = False Do While myIe.ReadyState <> READYSTATE_COMPLETE DoEvents Loop EndTime = Timer Sheets(1).Range("C1").Value = "讀取網頁" Sheets(1).Range("D1").Value = "共花費" & Format(EndTime - StartTime, "00.00") & "秒" Application.StatusBar = "資料分析中請稍候...." StartTime = Timer '引用 Document 對象 Set myHtmDoc = myIe.Document '============================================================================================== '列出網頁中的資料 '每一個網頁都不一樣,請依照想要讀取的網頁分析資料! For DocElemsCnt = 0 To myHtmDoc.all.Length - 1 DoEvents '引用item對象 Set myTable = myHtmDoc.all.Item(DocElemsCnt) 'tagName:獲取對象的標籤名稱。 If myTable.tagName = "P" Then '填入標題 Sheets(1).Range("A1").Value = myTable.previousSibling.data End If If myTable.tagName = "TABLE" Then 'tagName:若為table,則表示表格。 myTableRow = myTable.Rows.Length 'Rows.Length:取得TABLE(表格)的行數 myTableCell = myTable.Rows.Item(CellLen).Cells.Length 'Cell.Length:取得TABLE(表格)的欄數 ReDim myData(myTableRow, myTableCell) As String For RowLen = 0 To myTableRow - 1 For CellLen = 0 To myTableCell - 1 '利用巢狀迴圈填入陣列 myData(RowLen, CellLen) = myTable.Rows(RowLen).Cells(CellLen).innerText DoEvents Next CellLen DoEvents Next RowLen End If DoEvents Next DocElemsCnt '============================================================================================== '利用陣列填入Excel,精典方法!必學 Sheets(1).Range(Cells(3, 1), Cells(RowLen, CellLen)) = myData EndTime = Timer Sheets(1).Range("E1").Value = "分析資料" Sheets(1).Range("F1").Value = "共花費" & Format(EndTime - StartTime, "00.00") & "秒" Application.StatusBar = "資料已下載完畢........" myIe.Quit End Sub
範例三:自動登入網頁
Option Explicit Dim myWeb Sub CommandWeb() CommandWeb() Dim sURL As String sURL = "https://www.google.com/accounts/ServiceLogin?service=mail&passive=true&rm=false&continue=http%3A%2F%2Fmail.google.com%2Fmail%2F%3Fui%3Dhtml%26zy%3Dl&bsv=1k96igf4806cy<mpl=default<mplcache=2&hl=zh-TW" Set myWeb = UserForm1.WebBrowser1 myWeb.navigate (sURL) Do While myWeb.ReadyState <> READYSTATE_COMPLETE '等待網頁loading完成 DoEvents Loop Call Login End Sub Sub Login() Login() Dim vDoc, vTag Dim i, C As Integer Set vDoc = myWeb.Document For i = 0 To vDoc.all.Length - 1 '檢測所有標籤 If UCase(vDoc.all(i).tagName) = "INPUT" Then '找到input標籤 Set vTag = vDoc.all(i) If vTag.Type = "text" Then '判斷text欄位 Select Case vTag.Name Case "Email" '檢查帳號欄位 vTag.Value = "帳號" '請替換成正確的資料 End Select End If End If Next i For i = 0 To vDoc.all.Length - 1 '檢測所有標籤 If UCase(vDoc.all(i).tagName) = "INPUT" Then '找到input標籤 Set vTag = vDoc.all(i) If vTag.Type = "password" Then '判斷text欄位 Select Case vTag.Name Case "Passwd" '檢查帳號欄位 vTag.Value = "密碼" '請替換成正確的資料 End Select End If End If Next i myWeb.Document.all("signIn").Click '看這裡,只要一行 UserForm1.Show 0 End Sub