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

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

複製代碼