Excel VBA 自動下載網路檔案

Excel VBA 網路資料蒐集 完整教學:

https://raymondchiendtrt.blogspot.com/2018/08/vba_22.html

今天想來複習一下用VBA下載網路檔案的語法
於是想到了從公開資訊觀測站自動下載年報檔案

只要在Excel的A3儲存格輸入股票代號
接著從A6開始往下輸入要抓的年度即可



語法:

Sub getReportA()

Dim myXML As Object
Set myXML = CreateObject("Microsoft.XMLHTTP")

Dim myHTML As Object
Set myHTML = CreateObject("HTMLFile")

Dim oStream As Object
Set oStream = CreateObject("ADODB.Stream")

stockno = [A3]

LR = Cells(Rows.Count, "A").End(xlUp).Row

With myXML
    For i = 6 To LR
        Application.StatusBar = "抓取" & Cells(i, "A") & "年報中..."
        Cells(i, "B").Hyperlinks.Delete
        Application.Wait Now() + TimeValue("00:00:03")
        .Open "GET", "http://doc.twse.com.tw/server-java/t57sb01?step=1&colorchg=1&co_id=" & stockno & "&year=" & Cells(i, "A") & "&mtype=F&", False
        .send
        myHTML.body.innerHTML = .responseText
     
        Set myLinks = myHTML.getElementsByTagName("a")
        For Each myLink In myLinks
            If myLink.innerText Like "*F04*" Then
                myLink2 = myLink.innerText
                Exit For
            End If
        Next
     
        If myLink2 = "" Then Cells(i, "B") = "檔案不存在": GoTo myNext
     
        .Open "POST", "http://doc.twse.com.tw/server-java/t57sb01", False
        .send "colorchg=1&step=9&kind=F&co_id=" & stockno & "&filename=" & myLink2
     
        If Right(myLink2, 3) = "pdf" Then
            thePDF = [B3] & "\" & stockno & "_" & Cells(i, "A") & ".pdf"
            myLink3 = "http://doc.twse.com.tw" & Split(Split(Split(.responseText, "a href")(1), ">")(0), "'")(1)
            .Open "GET", myLink3, False
            .send
        ElseIf Right(myLink2, 3) = "doc" Or Right(myLink2, 3) = "zip" Then
            thePDF = [B3] & "\" & stockno & "_" & Cells(i, "A") & Right(myLink2, 3)
             .Open "POST", "http://doc.twse.com.tw/server-java/t57sb01", False
             .send "colorchg=1&step=9&kind=F&co_id=" & stockno & "&filename=" & myLink2
        End If
     
        If Dir(thePDF) <> "" Then Kill thePDF
     
        oStream.Open
        oStream.Type = 1
        oStream.Write .responseBody
        oStream.SaveToFile (thePDF)
        oStream.Close
        With Sheets("工作表1")
            .Hyperlinks.Add Anchor:=.Cells(i, "B"), Address:=thePDF, TextToDisplay:=Right(myLink2, 3)
        End With
myNext:
    Next i
 
End With

Application.StatusBar = "抓取完畢"

Set myXML = Nothing
Set oStream = Nothing
End Sub