- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
2#
發表於 2014-12-10 14:21
| 只看該作者
回復 1# flask
最近股票公開網頁資訊的下載,都有驗證碼防止自動下載.
由於驗證碼不好破解,可試試半自動下載
1請在工作表上插入一圖片(命名:驗證圖)
2圖片巨集指定為 ,Sheet1.圖形更新,這程式
為使VBA入門者,有實作經驗,故僅附上程式碼.
ThisWorkbook模組的程式碼- Option Explicit
- Private Sub Workbook_Open()
- Sheet1.Msg = True
- Run "Sheet1.圖形更新"
- End Sub
- Private Sub Workbook_BeforeClose(Cancel As Boolean)
- On Error Resume Next
- If Not Sheet1.IE Is Nothing Then Sheet1.IE.Quit
- End Sub
- Option Explicit
- 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 = ""
- Application.EnableEvents = True
- End If
- End With
- End Sub
- Private Sub 日報表載入()
- Dim e As Object, a As Object, K As Integer, i As Integer, ii As Integer, s As String
- If IE Is Nothing Then
- 圖形更新
- MsgBox "驗證圖已更新"
- Exit Sub
- End If
- With IE
- .Document.ALL.tags("INPUT")("stk_code").Value = Range(證券代號)
- .Document.ALL.tags("INPUT")("auth_num").Value = Trim(Range(驗證碼))
- Set a = .Document.ALL.tags("BUTTON")
- For Each e In a
- If Trim(e.innertext) = "查詢" And e.ID = "" Then
- e.Click
- Exit For
- End If
- Next
- Do While .Busy Or .readyState <> 4: DoEvents: Loop
- K = 6
- UsedRange.Offset(6).Clear
- If .Document.body.innertext Like "***該股票該日無交易資訊***" Then s = "***該股票該日無交易資訊***"
- If .Document.body.innertext Like "***驗證碼錯誤，請重新查詢。***" Then s = "***驗證碼錯誤，請重新查詢。*** "
- If s <> "" Then
- Range("a" & K + 1) = s
- MsgBox s
- GoTo NN
- End If
- Set a = .Document.ALL.tags("table")(0)
- For i = 0 To a.Rows.Length - 1
- K = K + 1
- For ii = 0 To a.Rows(i).Cells.Length - 1
- Cells(K, ii + 1) = a.Rows(i).Cells(ii).innertext
- Next
- Next
- Set a = .Document.ALL.tags("table")(2)
- K = K + 1
- For i = 0 To a.Rows.Length - 1
- K = K + 1
- For ii = 0 To a.Rows(i).Cells.Length - 1
- Cells(K, ii + 1) = a.Rows(i).Cells(ii).innertext
- Next
- Next
- Set a = .Document.ALL.tags("table")(3)
- For i = 1 To a.Rows.Length - 1
- K = K + 1
- For ii = 0 To a.Rows(i).Cells.Length - 1
- Cells(K, ii + 1) = a.Rows(i).Cells(ii).innertext
- Next
- Next
- MsgBox Range("d7") & " 日報表載入 完畢!!"
- NN:
- .Quit
- End With
- Set IE = Nothing
- 圖形更新
- End Sub
- Private Sub Get_Ie()
- Set IE = CreateObject("InternetExplorer.Application")
- With IE
- ' .Visible = True
- '券商買賣證券日報表查詢系統（一般交易）
- .Navigate "http://www.gretai.org.tw/web/stock/aftertrading/broker_trading/brokerBS.php?l=zh-tw"
- Do While .Busy Or .readyState <> 4: DoEvents: Loop
- End With
- End Sub
- Private Sub 圖形更新()
- If IE Is Nothing Then Get_Ie
- If Msg Then MsgBox "驗證圖 更新完畢"
- Msg = False
- With IE
- .Refresh
- Do While .Busy Or .readyState <> 4: DoEvents: Loop
- 網路圖片存檔 .Document.ALL.tags("IMG")(0).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-9 22:08
| 
