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

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

複製代碼