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

Option Explicit
Const 本益比 = "http://www.otc.org.tw/web/stock/aftertrading/peratio_analysis/pera.php"
Const 本益比download = "http://www.otc.org.tw/web/stock/aftertrading/peratio_analysis/pera_download.php?d="
Dim xDate As Date, Stk As String
Private Sub 個股本益比_殖利率及股價淨值比_依日期查詢()
Dim s As String, E As Variant, A
xDate = Date - 1
Do Until Weekday(xDate, vbFriday) < 6
xDate = xDate - 1
Loop
With CreateObject("InternetExplorer.Application")
.Visible = True
.Navigate 本益比
Do While .Busy Or .ReadyState <> 4: DoEvents: Loop
With .document
'資料日期：<input id="input_date" name="input_date" class="input-date ui-corner-all" onchange="query()" maxlength="6">
.ALL("input_date").Value = Format(xDate, "E/MM/DD") '
'D = .ALL("input_date").Value
'產業類別：<select id="stk_category" class="input-stk-cat ui-corner-all" onchange="query()">
.ALL("stk_category").Item(0).Selected = True '全部
'.ALL("stk_category").Item(8).Selected = True '第 9(0 -> 8) 項
Stk = .ALL("stk_category").Value
' .ALL("stk_category").fireEvent ("onchange")
With .ALL("stk_category")
For E = 0 To .Length - 1
If .Item(E).Value = .Value Then Stk = .Item(E).Value & " " & .Item(E).INNERTEXT
s = IIf(s = "", .Item(E).Value & " " & .Item(E).INNERTEXT, s & vbLf & .Item(E).Value & " " & .Item(E).INNERTEXT)
Next
End With
End With
MsgBox "你選擇: " & Stk & vbLf & vbLf & s, , "產業類別"
.Quit
End With
載入CSV
End Sub
Private Sub 載入CSV()
Dim xml As Object '用來取得網頁資料
Dim stream '用來儲存二進位檔案
Dim URL As String '目的網址
Dim xPath As String, xfile As String, W As Workbook
xPath = "d:\" '指定存檔路徑
xfile = xPath & Replace(Format(xDate, "E/MM/DD"), "/", "_") & " " & Split(Stk, " ")(1) & ".csv"
For Each W In Workbooks
If UCase(W.FullName) = UCase(xfile) Then W.Close: Exit For
Next
Set xml = CreateObject("Microsoft.XMLHTTP")
Set stream = CreateObject("ADODB.stream")
URL = 本益比download & Format(xDate, "E/MM/DD") & "&c=" & Split(Stk, " ")(0)
xml.Open "POST", URL, 0
xml.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
xml.send
With stream
.Open
.Type = 1
.write xml.ResponseBody
If Dir(xfile) <> "" Then Kill xfile
.SaveToFile (xfile)
.Close
End With
With Workbooks.Open(xfile).Sheets(1)
If .Range("A5") = "共0筆" Then
.Parent.Close
Kill xfile
MsgBox xDate & " - " & Stk & " 沒有資料"
Else
MsgBox xDate & " - " & Stk & Space(5) & .Cells(1).End(xlDown) & "資料"
End If
End With
End Sub

複製代碼