[原創] Excel VBA 自動抓取期交所期貨每日交易行情

文章來源:https://raymondchiendtrt.blogspot.com/2018/05/excel-vba_29.html

這次的程式是可以依據使用者輸入的日期
來抓到當天的期貨資料

這次結合了幾個技巧
1.設定Requestheader
以我之前觀察到的，如果是用Microsoft.XMLHTTP
即使設定requestheader也是無效的
所以必須改用WinHttp.WinHttpRequest.5.1

2.轉碼
我平常能不用WinHttp就不用
因為使用這個物件常常就會變成亂碼
必須多使用轉碼程式才能取的資料(請見下方的convertraw function)

3.使用clipboard
這個物件很好用，會把在網站上的格式一併下載下來
所以如果你要抓的資料有合併儲存格(像goodinfo)，或是有顏色等等的
可以用clipboard看看
但缺點就是createobject很難記XD，每次都要用查的
還有似乎不是每個表格(table)都抓的到，要試試看

4.使用application.wait
通常政府的網站若是抓太快很容易被鎖IP
所以利用此語法降低程式速度
一般來說設3秒就好，如果很怕被鎖可以再設久一點XD

大概是這樣，若有問題也歡迎在下方提出

Sub test()
Dim myXML As Object
Set myXML = CreateObject("WinHttp.WinHttpRequest.5.1")
Dim myHTML As Object
Set myHTML = CreateObject("HTMLFile")
Dim clipboard As Object
Set clipboard = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
ReDim myArr(1 To 10, 1 To 20)
dateLR = Cells(Rows.Count, "A").End(xlUp).Row
With myXML
For dateRow = 6 To dateLR
Application.Wait Now() + TimeValue("00:00:03")
myM = Format(Month(Cells(dateRow, "A")), "00")
myD = Format(Day(Cells(dateRow, "A")), "00")
.Open "POST", "http://www.taifex.com.tw/chinese/3/3_1_1.asp", False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.send "qtype=2&commodity_id=TX&commodity_id2=&market_code=0&goday=&dateaddcnt=0&DATA_DATE_Y=2018&DATA_DATE_M=05&DATA_DATE_D=22&syear=2018&smonth=" & myM & "&sday=" & myD & "&datestart=2018%2F05%2F15&MarketCode=0&commodity_idt=TX&commodity_id2t=&commodity_id2t2="
myHTML.body.innerHTML = convertraw(.responseBody)
'Debug.Assert InStr(1, myText, "10368") <> 0
Set myTables = myHTML.getElementsByTagName("table")
i = 1
For Each myTable In myTables
If myTable.getAttribute("width") = 965 Then
textLR = Cells(Rows.Count, "D").End(xlUp).Row
textLR = IIf(textLR = 1, 5, textLR + 5)
Cells(textLR, 4).Select
Cells(textLR - 1, 4) = myTable.PreviousSibling.innerText
Cells(textLR - 1, 4).WrapText = False
With clipboard
.SetText myTable.outerHTML
.PutInClipboard
End With
Sheets("工作表1").PasteSpecial NoHTMLFormatting:=False
Exit For
End If
Next
Next
End With
Set myXML = Nothing
End Sub
Function convertraw(rawdata)
Dim rawstr
Set rawstr = CreateObject("adodb.stream")
With rawstr
.Type = 1
.Mode = 3
.Open
.Write rawdata
.Position = 0
.Type = 2
.Charset = "UTF-8"
convertraw = .ReadText
.Close
End With
Set rawstr = Nothing
End Function