- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
回復 11# kasl
試試看- Option Explicit
- Const Code_txt = "D:\Code.Txt"
- Const FormDLL = "FM20.DLL"
- Sub Ex_Ie_下一頁()
- Dim IE As Object, URL As String, E As Variant, i As Integer
- Dim StartDate As Date, EndDate As Date
- Dim A As Variant, Table As Object, Ar_Code(), Code As Variant
- Set_FormDLL
- StartDate = DateAdd("yyyy", -1, Date) '1年前的日期
- 'StartDate = DateAdd("m", -1, Date) '1個月前的日期
- EndDate = Date
- MsgBox EndDate & " -- " & StartDate
- Ar_Code = Array("sgen", "AMEH", "HMNC") 'Code 的陣列
- 'Ar_Ccod() = Array("sgen", "AMEH", "HMNC", "OZM", "ARCC", "TDG", "ECL", "AN")
- Set IE = CreateObject("InternetExplorer.Application")
- With IE
- For Each Code In Ar_Code
- If Dir(Code_txt) <> "" Then Kill Code_txt
- URL = "http://www.cnyes.com/USAstock/history.aspx?code=" & Code
- ' .Visible = True ' 是否顯示 IE
- .Navigate URL
- Application.StatusBar = Code & " 網頁 開啟中..."
- Do While .Busy Or .readyState <> 4: DoEvents: Loop
- If .LocationURL = "http://www.cnyes.com/usastock/index.htm" Then
- MsgBox "Code 找不到 " & Code
- GoTo Code_Next
- End If
- Application.StatusBar = Code & "日期 " & EndDate & " -- " & StartDate & " 指定中..."
- With .document.getElementsByTagName("SELECT") '月份輸入
- .Item("startMonth").Value = Month(StartDate) - 1 '開始月份
- .Item("endMonth").Value = Month(EndDate) - 1 '結束月份
- End With
- With .document.getElementsByTagName("INPUT")
- .Item("startDay").Value = Day(StartDate) '開始日期
- .Item("startDay").Value = Day(StartDate) '開始日期
- .Item("startYear").Value = Year(StartDate) '開始年度
- .Item("endDay").Value = Day(EndDate) '結束日期
- .Item("endYear").Value = Year(EndDate) '結束年度
- .Item("perPage").Value = 100 '顯示資料的筆數
- End With
- For Each E In .document.getElementsByTagName("BUTTON")
- If E.Type = "submit" Then
- E.Click '按下搜尋鍵
- Exit For
- End If
- Next
- Application.StatusBar = "按下搜尋鍵 等候網頁中... "
- Do While .Busy Or .readyState <> 4: DoEvents: Loop
- Application.Wait Time + #12:00:10 AM# '等候網頁
- Set Table = .document.getElementsByTagName("TABLE")
- For Each E In .document.getElementsByTagName("SPAN")
- If InStr(E.innerText, "Page of") Then
- i = Val(Replace(E.innerText, "Page of", "")) '取得資料總頁數
- Exit For
- End If
- Next
- On Error GoTo Ie_Err
- For A = 0 To i
- Application.StatusBar = Code & " " & EndDate & " -- " & StartDate & "共 " & i & " 頁 下載 第 " & A + IIf(A = 0, 1, 0) & " 中..."
- For Each E In .document.getElementsByTagName("A")
- If Trim(E.innerText) = ">" Then
- If A > 1 Then E.Click '下一頁按鍵
- Do While .Busy Or .readyState <> 4: DoEvents: Loop
- Application.Wait Time + #12:00:05 AM# '等候網頁
- Set Table = .document.getElementsByTagName("TABLE")
- Exit For
- End If
- Next
- If A = 0 Or A > 1 Then
- Close #1
- Open Code_txt For Append As #1
- Print #1, Table(12).outerHTML
- Close #1
- End If
- Next
- Date_of_refresh Code, A '導入資料程式 要給參數 Code , A
- Code_Next:
- Next
- .Quit
- End With
- Application.StatusBar = False
- Remove_FormDLL
- MsgBox "Ok"
- Exit Sub
- Ie_Err:
- Application.Wait Time + #12:00:05 AM# '等候網頁
- Set Table = IE.document.getElementsByTagName("TABLE")
- Resume
- End Sub
- Private Sub Date_of_refresh(ByVal Code As String, ByVal xPage As Integer) '導入資料程式
- Dim AR(), i As Long, S As Variant, Sy As String, Ta As String
- Dim D As New DataObject, SH As Worksheet
- On Error GoTo Sh_Err
- With CreateObject("Scripting.FileSystemObject").OpenTextFile(Code_txt)
- Ta = .Readall
- .Close
- End With
- With D
- .SetText Ta
- .PutInClipboard
- End With
- With ThisWorkbook.Sheets(Code)
- .Range("a1").PasteSpecial
- If xPage > 1 Then
- With .Range("A:A").SpecialCells(xlCellTypeConstants).Offset(1)
- .Replace "Date", "=xxx", xlWhole
- .SpecialCells(xlCellTypeFormulas, xlErrors).EntireRow.Delete
- End With
- End If
- AR = .Range("A:A").SpecialCells(xlCellTypeConstants).Value
- AR = Application.Transpose(AR)
- '日期整理 ***************
- For i = 2 To UBound(AR)
- S = Split(AR(i), "/")
- Sy = "20"
- If Val(S(2)) > Mid(Year(Date), 3) Then Sy = "19"
- If Len(S(0)) = 2 Then
- S = Sy & S(2) & "/" & S(0) & "/" & S(1)
- ElseIf Len(S(0)) = 4 Then
- S = Sy & S(2) & "/" & Mid(S(0), 3) & "/" & S(1)
- End If
- AR(i) = S
- Next
- .Range("A:A").SpecialCells(xlCellTypeConstants).Value = Application.Transpose(AR)
- '*****************************
- Application.Goto .Range("A1")
-
- End With
- Exit Sub
- Sh_Err:
- If Err = 9 Then
- ThisWorkbook.Sheets.Add.Name = Code
- Err.Clear
- End If
- On Error GoTo 0
- Resume
- End Sub
- Private Sub Set_FormDLL() '新增引用 Microsoft Forms 2.0 Object Library
- On Error Resume Next
- ThisWorkbook.VBProject.References.AddFromFile "C:\windows\system32\" & FormDLL
- 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 網頁的元素()
- Dim URL As String, A As Object, i As Integer
- URL = "http://www.cnyes.com/USAstock/history.aspx?code=sgen"
- With CreateObject("InternetExplorer.Application")
- ' .Visible = True ' 是否顯示 IE
- .Navigate URL
- Do While .readyState <> 4
- DoEvents
- Loop
- Set A = .document.all
- On Error Resume Next
- With ActiveSheet
- .Cells.Clear
- For i = 0 To A.Length - 1
- .Cells(i + 1, "a") = A(i).tagname
- .Cells(i + 1, "b") = A(i).ID
- .Cells(i + 1, "c") = A(i).Name
- .Cells(i + 1, "d") = A(i).Type
- .Cells(i + 1, "e") = A(i).Value
- .Cells(i + 1, "f") = A(i).innerText
- .Cells(i + 1, "g") = A(i).class
- .Cells(i + 1, "g") = A(i).class
- Next
- End With
- .Quit
- End With
- End Sub
|
|
發表於 2014-5-28 16:57
| 