Public FindLinks As Boolean
Public rRow As Integer
Sub FindURL(sURL As String)
Dim IE As New InternetExplorer
Dim oDoc As New MSHTML.HTMLDocument
Dim oLink As HTMLAnchorElement
Dim i As Integer
FindLinks = False
IE.navigate sURL
Do While IE.ReadyState <> READYSTATE_COMPLETE
UrlForm.Label1.Caption = "網頁:" & sURL & " 連線中請稍候......"
DoEvents
Loop
UrlForm.Label1.Caption = ""
'引用 Document 對象
Set oDoc = IE.Document
'列出網頁中的新聞資料
Call ListTableinnertext(oDoc)
'獲取以順序排列的HTML 標籤中所有 Links 對象的集合。
For i = 0 To oDoc.Links.Length - 1
On Error Resume Next
'尋找 Links 對象中innerText為"下頁"的標籤
'因為網站為簡體，而我是使用繁體，所以才會使用 Like "下*"的方法
'如果是簡體的環境可以直接改成 oDoc.Links(i).innerText="下頁"
If Len(oDoc.Links(i).innerText) = 2 And oDoc.Links(i).innerText Like "下*" Then
'href:獲取目標URL(完整網址)
UrlForm.ListBox1.AddItem oDoc.Links(i).href
Set oLink = oDoc.Links(i)
If Not oLink Is Nothing Then
pURL = oLink.href
UrlForm.WebBrowser1.navigate pURL
FindLinks = True
End If
End If
Next i
If FindLinks = False Then pURL = ""
Set oDoc = Nothing
Set IE = Nothing
End Sub
Sub ListTableinnertext(oDoc)
Dim DocElemsCnt As Integer
Dim Tbl As Object
For DocElemsCnt = 0 To oDoc.all.Length - 1
'tagName:獲取對象的標籤名稱。
If oDoc.all.Item(DocElemsCnt).tagName = "TABLE" Then
Set Tbl = oDoc.all.Item(DocElemsCnt)
'每個網頁有很多TABLE(表格)，而要取得資料的TABLE(表格)共有40列， _
可以利用此特性來取得正確的TABLE(表格)
If Tbl.Rows.Length > 20 Then
'Tbl.Rows.Length:取得TABLE(表格)的列數
For RwLen = 0 To Tbl.Rows.Length - 1
rRow = rRow + 1
'Int(Tbl.Cells.Length / Tbl.Rows.Length):可取得TABLE(表格)共有幾欄
For Colen = 0 To Int(Tbl.Cells.Length / Tbl.Rows.Length) - 1
Cells(rRow, Colen + 1).Value = Tbl.Rows(RwLen).Cells(Colen).innerText
Next Colen
Next RwLen
End If
End If
Next DocElemsCnt
Application.Goto Cells(rRow, 1), Scroll:=True
End Sub
Sub FormShow()
UrlForm.Show 0
End Sub
Dim k As Integer
Sheet2.Activate
Cells.Clear
k = 3
rRow = 0
pURL = "http://scripts.sportscn.com/portal/football/italy/news.php?rscnt=502&page=1"
Me.ListBox1.Clear
Me.ListBox1.AddItem pURL
'pURL 如果為空字串表示已到最後一筆資料
Do While pURL <> ""
FindURL pURL
Loop
MsgBox "網址全部連結完完成"
Columns("A:B").EntireColumn.AutoFit
End Sub
留言列表
案件 (0)
