- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
9#
發表於 2014-12-26 09:18
| 只看該作者
回復 8# abba9817
不了解可參考這裡
上市工作表模組的程式碼- Public ie As Object, Msg As Boolean
- Const 圖形 = "d:\驗證圖.jpg"
- Const 證券代號 = "F2"
- Const 驗證碼 = "F4"
- Private Sub Worksheet_Change(ByVal Target As Range)
- Range(證券代號).Interior.ColorIndex = IIf(Range(證券代號).Value = "", 2, 36)
- With Target.Cells(1)
- If .Address(0, 0) = 驗證碼 Then .Interior.ColorIndex = IIf(Len(Trim(.Cells)) = 5, 36, 2)
- If .Address(0, 0) = 驗證碼 And Len(Trim(.Cells)) = 5 And Range(證券代號).Value <> "" Then
- If ie Is Nothing Then
- Target = ""
- Msg = True
- 圖形更新
- Exit Sub
- End If
- Application.EnableEvents = False
- 讀取日報表網頁
- Target = ""
- Me.Activate
- Application.EnableEvents = True
- End If
- End With
- End Sub
- Private Sub 讀取日報表網頁()
- Dim S As String
- Application.EnableEvents = True
- If ie Is Nothing Then
- 圖形更新
- MsgBox "驗證圖已更新"
- Exit Sub
- End If
- With ie
- .navigate "http://bsr.twse.com.tw/bshtm/bsMenu.aspx"
- Do While .Busy Or .readyState <> 4: DoEvents: Loop
- .Document.All("TextBox_Stkno").Value = Range(證券代號)
- .Document.All("CaptchaControl1").Value = Range(驗證碼)
- .Document.All("btnOK").Click
- Do While .Busy Or .readyState <> 4: DoEvents: Loop
- If InStr(.Document.body.Innertext, "查無資料") Then
- S = Range(證券代號) & " 查無資料"
- ElseIf InStr(.Document.body.Innertext, "驗證碼錯誤!") Then
- S = "驗證碼錯誤!"
- Else
- 日報表下載
- 日報表_整理_存檔
- S = "下載 " & Range(證券代號) & " CSV OK"
- With Cells(Rows.Count, 1).End(xlUp)
- If .Row < 6 Then
- Range("A6") = S
- Else
- .Cells(2) = S
- End If
- End With
- End If
- [A1] = S
- End With
- 圖形更新
- End Sub
- Private Sub 日報表下載()
- With CreateObject("InternetExplorer.Application")
- .Visible = True
- .navigate "http://bsr.twse.com.tw/bshtm/bsContent.aspx?v=t"
- Do While .Busy Or .readyState <> 4: DoEvents: Loop
- .ExecWB 17, 2
- .ExecWB 12, 2
- .Quit
- End With
- End Sub
- Private Sub 日報表_整理_存檔()
- Dim Rng As Range, E As Range
- With Sheet2
- .Activate
- .UsedRange.Clear
- .Range("A1").Select
- .PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False, NoHTMLFormatting:=True
- .UsedRange.Offset(10).Columns(1).Replace "交易日期", "=aaa", xlWhole
- With .UsedRange
- For Each E In .SpecialCells(xlCellTypeFormulas, xlErrors).Areas
- If Rng Is Nothing Then
- Set Rng = E.Offset(-1).Resize(5, 16)
- Else
- Set Rng = Union(Rng, E.Offset(-1).Resize(5, 16))
- End If
- Next
- .SpecialCells(xlCellTypeBlanks).Delete xlShiftToLeft
- End With
- Rng.Delete
- .Copy '工作複製
- End With
- Application.DisplayAlerts = False
- With ActiveWorkbook
- .Sheets(1).Name = Range(證券代號)
- '*******"D:\TEST\" 可修改 ************************
- .SaveAs "D:\TEST\" & Range(證券代號).Text & ".CSV"
- '*************************************************
- .Close True
- End With
- Application.DisplayAlerts = True
- End Sub
- Private Sub 圖形更新()
- Shell "RunDll32.exe InetCpl.cpl,ClearMyTracksByProcess 8" 'Clear_IE_Temp_Files
- If Not ie Is Nothing Then ie.Quit: Set ie = Nothing
- Set ie = CreateObject("InternetExplorer.Application")
- If Msg Then MsgBox "驗證圖 更新完畢"
- Msg = False
- With ie
- .navigate "http://bsr.twse.com.tw/bshtm/bsMenu.aspx"
- .Visible = True
- Do While .Busy Or .readyState <> 4: DoEvents: Loop
- 網路圖片存檔 .Document.All.TAGS("IMG")(1).href
- End With
- Sheet1.Shapes("驗證圖").Fill.UserPicture 圖形
- End Sub
- Private Sub 網路圖片存檔(img As String)
- Dim xml As Object '用來取得網頁資料
- Dim stream 'As ADODB.stream '用來儲存二進位檔案
- Set xml = CreateObject("Microsoft.XMLHTTP")
- Set stream = CreateObject("ADODB.stream")
- xml.Open "GET", img, 0
- xml.send
- With stream
- .Open
- .Type = 1
- .write xml.responseBody
- If Dir(圖形) <> "" Then Kill 圖形
- .SaveToFile (圖形)
- .Close
- End With
- End Sub
|
|
發表於 2014-12-25 12:29
| 
