麻辣家族討論版版 - Powered by Discuz! Board

Sub GetData()
URL = "https://eservices.customs.gov.hk/MSOS/wsrh/001s1?searchBy=A"
With CreateObject("InternetExplorer.Application")
.Visible = True ' 是否顯示 IE
.Navigate URL
Do While .ReadyState <> 4 Or .Busy
DoEvents
Loop
xlHtm = .Document.body.innerHTML
End With
End Sub

複製代碼

Option Explicit
Const FormDLL = "FM20.DLL"
Sub IE下一頁()
Dim URL As String, A As Object, Table As Object, i As Integer, pubSrch As Object, Pages As Integer
Dim Sh As Worksheet, B As String
Set_FormDLL
Set Sh = ActiveSheet
Sh.Cells.Clear
URL = "https://eservices.customs.gov.hk/MSOS/wsrh/001s1?searchBy=A"
With CreateObject("InternetExplorer.Application")
.Visible = True ' 是否顯示 IE
.Navigate URL
Do While .ReadyState <> 4 Or .Busy
DoEvents
Loop
Set A = .Document.getElementsByTAGName("A")
For i = 0 To A.Length - 1
If A(i).innertext = "ALL" Then
A(i).Click
Exit For
End If
Next
Do While .ReadyState <> 4 Or .Busy
DoEvents
Loop
Do
Set A = .Document.getElementsByTAGName("TD")
Loop Until Not A Is Nothing And A.Length = 84
For i = 0 To A.Length - 1
If A(i).ID = "grid-table-pubSrch_center" Then
Pages = Val(Replace(A(i).innertext, "Page of ", "")) '總頁數
End If
If A(i).ID = "next_grid-table-pubSrch" Then Set pubSrch = A(i) '下一頁按鍵
Next
Set Table = .Document.getElementsByTAGName("table")
For i = 1 To Pages
If i >= 2 Then
pubSrch.Click
Do While .ReadyState <> 4 Or .Busy: Loop
Set Table = .Document.getElementsByTAGName("table")
Do: Loop Until B <> Table(6).outerHTML
End If
Ep Sh, Table(6).outerHTML
B = Table(6).outerHTML
Next
.Quit
End With
With Sh
.Cells.WrapText = False
Intersect(Range("b:b").SpecialCells(xlCellTypeBlanks).EntireRow, .Range("c:c").SpecialCells(xlCellTypeBlanks).EntireRow).Delete
.Cells.EntireRow.AutoFit
.Range("a1").Activate
End With
Remove_FormDLL
End Sub
Private Sub Set_FormDLL() '新增引用 Microsoft Forms 2.0 Object Library
On Error Resume Next
ThisWorkbook.VBProject.References.AddFromFile "C:\windows\system32\" & FormDLL
' On Error GoTo 0
End Sub
Private Sub Remove_FormDLL() '刪除引用 Microsoft Forms 2.0 Object Library
Dim D As Object
For Each D In ThisWorkbook.VBProject.References
If UCase(D.fullpath) Like "*" & FormDLL Then
ThisWorkbook.VBProject.References.Remove D
End If
Next
End Sub
Private Sub Ep(Sh As Worksheet, S As String)
Dim D As New DataObject, E As Shape, FormDLL As String ', Rng As Range
'DataObject 物件在進行轉換動作時，做為格式化文字資料的暫存區域。其也可以暫存和儲存在 DataObject 的文字片段相關的格式。
'宣告 Dim D As New DataObject '須在工具-> 設定引用項目加入新增引用 Microsoft Forms 2.0 Object Library ,專案加入一表單即可
With D
.SetText S
.PutInClipboard
With Sh
.Cells(.Rows.Count, "b").End(xlUp).Offset(1, -1).Select
.PasteSpecial Format:="Unicode 文字"
End With
End With
End Sub

複製代碼

Do
Set A = .Document.getElementsByTAGName("TD")
Loop Until Not A Is Nothing And A.Length = 84

複製代碼

Do
Set A = .Document.getElementsByTAGName("TD")
Loop Until Not A Is Nothing And A.Length = 84

複製代碼

Set A = .Document.getElementsByTAGName("TD")

複製代碼

Do
Set A = .Document.getElementsByTAGName("TD")
Loop Until Not A Is Nothing And A.Length = 84
MsgBox A.Length '可看看倒底是多少

複製代碼

'網頁搜尋結果: 0 記錄
Option Explicit
Sub IE下一頁()
Dim url As String, a As Object, Table As Object, i As Integer, pubSrch As Object, Pages As Integer
Dim Sh As Worksheet, B As String, E
Set Sh = ActiveSheet
Sh.Cells.Clear
'************************************
url = "https://eservices.customs.gov.hk/MSOS/wsrh/001s1?"
'url = "https://eservices.customs.gov.hk/MSOS/wsrh/001s1?"searchBy=A" '網頁有資料
'************************************
With CreateObject("InternetExplorer.Application")
.Visible = True ' 是否顯示 IE
.Navigate url
Do While .ReadyState <> 4 Or .Busy
DoEvents
Loop
Do
Set a = .Document.getElementsByTAGName("TD")
Loop Until Not a Is Nothing 'And a.Length = 84
On Error Resume Next
With Sh
For i = 0 To a.Length - 1
.Cells(i + 1, "A") = i
.Cells(i + 1, "B") = a(i).Type
.Cells(i + 1, "C") = a(i).ID
.Cells(i + 1, "D") = a(i).InnerText
.Cells(i + 1, "E") = a(i).Value
Next
End With
.Quit
End With
MsgBox "getElementsByTAGName(""TD"") 合計 " & a.Length
End Sub

複製代碼