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

標題: 請問如何將網頁的圖片存檔 [打印本頁]

作者: flask 時間: 2014-12-9 22:08 標題: 請問如何將網頁的圖片存檔

With CreateObject("InternetExplorer.application")
      .Visible = True
      .Navigate "http://www.gretai.org.tw/web/stock/aftertrading/broker_trading/brokerBS.php?l=zh-tw"

      Do Until .ReadyState = 4
         DoEvents
      Loop
Set img = .document.all.tags("img")(0)
end with
請問我如何把img這個圖存成c:\2.png

作者: GBKEE 時間: 2014-12-10 14:21

回復 1# flask
最近股票公開網頁資訊的下載,都有驗證碼防止自動下載.
由於驗證碼不好破解,可試試半自動下載
1請在工作表上插入一圖片(命名:驗證圖)
2圖片巨集指定為 ,Sheet1.圖形更新,這程式
為使VBA入門者,有實作經驗,故僅附上程式碼.

[attach]19741[/attach]

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

複製代碼

Sheet1模組的程式碼

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

複製代碼

作者: flask 時間: 2014-12-10 19:29

感謝GBKEE大大的回答!
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
以這方式下載的圖片與IE頁面的圖不是相同的圖
要如何下載回來的是IE頁面的圖,因為它是PNG檔
我試了幾種方式都沒辦法是IE頁面的圖,驗證碼的
圖要轉成BMP格式才能做2值化的處理.如果不是PNG
檔的話用GetClipboardData就可以處理了!一直想
破頭個人的功力實在太淺了還在學習中!希望老師
能提點一下!

作者: flask 時間: 2014-12-11 02:39

測試完發現驗證碼輸入頁面上的碼與存檔圖上的碼都是OK的??

作者: flask 時間: 2014-12-11 21:06

下載的圖片與IE頁面的圖不是相同的圖
導入都會"驗證碼已逾期，請重新查詢"
失敗!如何抓下來圖是ie頁面顯示的圖片咧?

作者: GBKEE 時間: 2014-12-12 05:38

回復 5# flask
程式執行如圖

[attach]19763[/attach]

作者: flask 時間: 2014-12-12 08:31

原來是驗證碼tessdata-OCR視別錯誤!

作者: wufonna 時間: 2014-12-13 11:51

回復 6# GBKEE
請問版大這是那裡出錯
謝謝

作者: GBKEE 時間: 2014-12-13 13:23

本帖最後由 GBKEE 於 2014-12-13 13:24 編輯

回復 8# wufonna
這錯誤是你將 IE關閉了
VBA按下重設,重新執行程式

Private Sub Get_Ie()
Set IE = CreateObject("InternetExplorer.Application")
With IE
' .Visible = True *** 不顯示就是防止使用者關閉IE
'券商買賣證券日報表查詢系統（一般交易）
.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

複製代碼

[attach]19776[/attach]

插入的圖片需使用繪圖的圖片

工作表1.Shapes("驗證圖").Fill.UserPicture 圖形

複製代碼

附檔插入的圖片沒改名稱驗證圖
也可以使用 Shapes(索引值)->如Shapes(1)

作者: wufonna 時間: 2014-12-13 14:38

回復 9# GBKEE

GBKEE 大
執行有開啟IE
錯諤碼如下，還是我有那一步做了，謝謝

檔安同放D:\ 根目下

作者: GBKEE 時間: 2014-12-13 15:04

回復 10# wufonna

你的附檔
插入的圖片需使用繪圖的圖片
一樣你的附檔的圖片沒改名稱為 "驗證圖"
給你除錯程式碼

Private Sub 圖形更新()
On Error GoTo ER
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
MsgBox 工作表1.Shapes("驗證圖").Name
工作表1.Shapes("驗證圖").Fill.UserPicture 圖形 '
Exit Sub
ER:
MsgBox Err & vbLf & Err.Description
Stop
MsgBox 工作表1.Shapes(1).Name
Resume
End Sub

複製代碼

作者: wufonna 時間: 2014-12-13 17:24

回復 11# GBKEE
GBKEE 大大
2010版的找不到圖片如何更名，
這程式是要先看圖片的字再輸入 F2 和 f4 才可輸出嗎
程式還不清楚，研究看看不會再請教大大
謝謝 GBKEE 版大

作者: wufonna 時間: 2014-12-13 19:28

回復 11# GBKEE

謝謝 GBKEE 大大
* 使用繪圖的圖片
可以了 ^_^

作者: GBKEE 時間: 2014-12-14 05:45

回復 12# wufonna
2010版的找不到圖片如何更名
如圖到名稱方塊中修改

[attach]19787[/attach]

VBA修改

With 工作表1
.Shapes(1).Name = "驗證圖"
.Shapes("驗證圖").Fill.UserPicture 圖形 '
End With

複製代碼

作者: HSIEN6001 時間: 2014-12-14 12:24

回復 14# GBKEE

[attach]19789[/attach]

請問,該如何載入其他頁次
若不用寫入Excel,而直接 .Click 下載CSV檔(BIG5) 檔案
語法該怎麼修正

Set aa = .Document.getElementsByTAGName("INPUT")
For R = 0 To aa.Length - 1
If aa(R).Value = "下載CSV檔(BIG5)" And aa(R).Type = "button" Then
aa(R).Click '有 "下載CSV檔(BIG5)" 的按鈕
Do While .Busy Or .ReadyState <> 4: DoEvents: Loop
End If
Next

複製代碼

作者: wufonna 時間: 2014-12-14 13:05

回復 14# GBKEE

原來就在面前哈
謝謝 GBKEE 大大

作者: wufonna 時間: 2014-12-14 15:00

本帖最後由 wufonna 於 2014-12-14 15:09 編輯

回復 14# GBKEE

請問大大第一段對應的是這程式碼嗎，那第二段的我這樣改為何查無該股票代碼資料
諸問大大如何有誤，改如何做練習，謝謝

<button type="submit" class="btn btn-default"><span class="glyphicon glyphicon-search" aria-hidden="true"></span> 查詢</button>

   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

<input type="radio" id="rdo_search_stk" tabindex="14" name="rdo_search" value="1" class="input-radio-search" checked><span>個股查詢</span>
<button id="header_search_btn" tabindex="17" class="input-button ui-corner-all" tabindex="13">搜尋</button>

Sub test()
Dim e As Object, a As Object
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
      .Document.ALL.tags("INPUT")("rdo_search_stk").Value = 1
      .Document.ALL.tags("INPUT")("input_search_site").Value = Trim(1258)
      Set a = .Document.ALL.tags("BUTTON")
      For Each e In a
      If e.ID = "header_search_btn" Then
         e.Click
         Exit For
      End If
      Next
End With
End Sub

作者: wufonna 時間: 2014-12-14 18:08

回復 14# GBKEE

謝謝 GBKEE 版大
是我看錯了

.Document.ALL.tags("INPUT")("input_search_stk").Value = Trim(1258)

作者: GBKEE 時間: 2014-12-16 10:20

回復 15# HSIEN6001

若不用寫入Excel,而直接 .Click 下載CSV檔(BIG5) 檔案
對IE的涉獵尚淺找不出下載CSV檔的參數,有請高手指點

載入其他頁次
Dim IEx As Object '工作表模組

Private Sub 日報表載入()
Dim e As Object, A As Object, k As Integer, i 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
UsedRange.Offset(6).Clear
Range("a" & k + 1) = S
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 IEx = CreateObject("InternetExplorer.Application")
IEx.Navigate "about:Tabs"
Set A = .Document.all.tags("A")
單頁載入 .Document.all.tags("table")(0).outerHTML
[A6].Select
'********程式碼寫在工作表模組: Me 指這工作表模組
Me.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False, NoHTMLFormatting:=True
'****************************************
If A.Length = 459 Then
For i = 2 To 3
單頁載入 .Document.all.tags("table")(i).outerHTML
With Range("A" & Rows.Count).End(xlUp).Offset(1)
.Select
Me.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False, NoHTMLFormatting:=True
End With
Next
Else
For k = 0 To A.Length - 1
If Val(A(k).Innertext) >= 1 Then
Debug.Print A(k).Innertext
A(k).Click
Do While .Busy Or .readyState <> 4: DoEvents: Loop
Set A = .Document.all.tags("A")
Do While .Busy Or .readyState <> 4: DoEvents: Loop
For i = 2 To 3
單頁載入 .Document.all.tags("table")(i).outerHTML
With Range("A" & Rows.Count).End(xlUp).Offset(1)
.Select
Me.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False, NoHTMLFormatting:=True
End With
Next
End If
Next
End If
IEx.Quit
Set IEx = Nothing
整理
NN:
.Quit
End With
Set IE = Nothing
圖形更新
End Sub
Private Sub 單頁載入(S)
With IEx
.Document.body.innerHTML = S
.ExecWB 17, 2 ' Select All
.ExecWB 12, 2 ' Copy selection
End With
End Sub
Private Sub 整理()
On Error Resume Next
Application.EnableEvents = False
With UsedRange.Offset(10)
.Replace "序號", "=ex", xlWhole
.SpecialCells(xlCellTypeFormulas, xlErrors).EntireRow.Delete
End With
UsedRange(1).Select
Application.EnableEvents = True
End Sub

複製代碼

作者: HSIEN6001 時間: 2014-12-16 12:29

回復 19# GBKEE

耶!成了

謝謝您的指導！
程式語言，博大精深
對我來說很艱難，因為好用，還是很努力的盡量多吸收一些
還沒看懂的部分，也先收集起來，待日後消化

~感恩~

作者: joey0415 時間: 2014-12-16 13:05

回復 19# GBKEE

請問在第一段的

If IE Is Nothing Then

說此處需要物件，請問超版如何修正呢？

作者: HSIEN6001 時間: 2014-12-16 14:38

回復 21# joey0415

整段語法是這樣的 , 綜合 #2 & #9
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

複製代碼

Sheet1模組的程式碼

Option Explicit
Public IE As Object, Msg As Boolean, IEx As Object
Const 圖形 = "C:\驗證圖.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, 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
UsedRange.Offset(6).Clear
Range("a" & k + 1) = S
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 IEx = CreateObject("InternetExplorer.Application")
IEx.Navigate "about:Tabs"
Set A = .Document.all.tags("A")
單頁載入 .Document.all.tags("table")(0).outerHTML
[A6].Select
'********程式碼寫在工作表模組: Me 指這工作表模組
Me.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False, NoHTMLFormatting:=True
'****************************************
If A.Length = 459 Then
For i = 2 To 3
單頁載入 .Document.all.tags("table")(i).outerHTML
With Range("A" & Rows.Count).End(xlUp).Offset(1)
.Select
Me.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False, NoHTMLFormatting:=True
End With
Next
Else
For k = 0 To A.Length - 1
If Val(A(k).Innertext) >= 1 Then
Debug.Print A(k).Innertext
A(k).Click
Do While .Busy Or .readyState <> 4: DoEvents: Loop
Set A = .Document.all.tags("A")
Do While .Busy Or .readyState <> 4: DoEvents: Loop
For i = 2 To 3
單頁載入 .Document.all.tags("table")(i).outerHTML
With Range("A" & Rows.Count).End(xlUp).Offset(1)
.Select
Me.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False, NoHTMLFormatting:=True
End With
Next
End If
Next
End If
IEx.Quit
Set IEx = Nothing
整理
NN:
.Quit
End With
Set IE = Nothing
圖形更新
End Sub
Private Sub 單頁載入(S)
With IEx
.Document.body.innerHTML = S
.ExecWB 17, 2 ' Select All
.ExecWB 12, 2 ' Copy selection
End With
End Sub
Private Sub 整理()
On Error Resume Next
Application.EnableEvents = False
With UsedRange.Offset(10)
.Replace "序號", "=ex", xlWhole
.SpecialCells(xlCellTypeFormulas, xlErrors).EntireRow.Delete
End With
UsedRange(1).Select
Application.EnableEvents = True
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

複製代碼

作者: HSIEN6001 時間: 2014-12-16 15:04

本帖最後由 HSIEN6001 於 2014-12-16 15:06 編輯

回復 19# GBKEE

您好,我已經找到CSV下載的參數
GET
URL = "http://www.gretai.org.tw/web/stock/aftertrading/broker_trading/download_ALLCSV.php?curstk=" & 證券代號 & "&stk_date=" & 日期 & "&auth=" & 驗證碼

我把表身匯入改成這段

Dim xml As Object '用來取得網頁資料
Dim stream 'As ADODB.stream '用來儲存二進位檔案
Set xml = CreateObject("Microsoft.XMLHTTP")
Set stream = CreateObject("ADODB.stream")
Dim path As String, url
path = "C:\"
Dim 日期 As String
日期 = "1031215"
'GET http://www.gretai.org.tw/web/stock/aftertrading/broker_trading/download_ALLCSV.php?curstk=股票代號&stk_date=日期&auth=驗證碼
url = "http://www.gretai.org.tw/web/stock/aftertrading/broker_trading/download_ALLCSV.php?curstk=" & Sheets("Sheet1").[F2] & "&stk_date=" & 日期 & "&auth=" & Sheets("Sheet1").[F4]
xml.Open "GET", url, 0
xml.send
With stream
.Type = 1
.Open
.write xml.responseBody
If Dir(path & Sheets("Sheet1").[F2] & ".csv") <> "" Then Kill (path & Sheets("Sheet1").[F2] & ".csv")
.SaveToFile (path & Sheets("Sheet1").[F2] & ".csv")
.Close
End With

複製代碼

非常謝謝您的指導!!
^__^

作者: joey0415 時間: 2014-12-16 18:20

回復 23# HSIEN6001
可不可分享一個做好的zip檔，方便研究嗎？

這麼多Private Sub，不太會與修改

謝謝啦

作者: flask 時間: 2014-12-16 19:21

Sheets("上櫃股票").Activate
With CreateObject("InternetExplorer.application")          '創建一個空的ie
      .Visible = True                                        '讓ie可見
      .Navigate "http://www.gretai.org.tw/web/stock/aftertrading/broker_trading/brokerBS.php?l=zh-tw"
      Do Until .ReadyState = 4             '等待ie完畢載入
         DoEvents
      Loop
      code = InputBox("輸入驗證碼", "code", code)
      For Each stock In Range([a2], [a65536].End(xlUp))'股票代號

      .Document.ALL("stk_code").Value = stock '填寫股票代號
      .Document.ALL("auth_num").Value = code '填寫驗證碼

With Sheets("web")
   .Cells.Delete
   .QueryTables.Add Connection:="URL;", Destination:=.Range("A1")

With .QueryTables.Add(Connection:="URL;http://www.gretai.org.tw/web/stock/aftertrading/broker_trading/download_ALLCSV.php?curstk=" & stock & "&stk_date=" & 日期 & "&auth=" & code & "", Destination:=.[a1])
      .AdjustColumnWidth = False
      .WebFormatting = xlWebFormattingNone
      .WebDisableDateRecognition = False
      .Refresh BackgroundQuery:=False
End With

.Columns("A:A").TextToColumns Destination:=.Range("A1"), DataType:=xlDelimited, _
      TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
      Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
      :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
      Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1)), _
      TrailingMinusNumbers:=True

End With
End With
上櫃驗證碼有60秒的有效性,只要打個10來次就可下載完!

作者: flask 時間: 2014-12-16 19:46

Sheets("上櫃股票").Activate
With CreateObject("InternetExplorer.application")          '創建一個空的ie
      .Visible = True                                        '讓ie可見
      .Navigate "http://www.gretai.org.tw/web/stock/aftertrading/broker_trading/brokerBS.php?l=zh-tw"

      Do Until .ReadyState = 4             '等待ie完畢載入
         DoEvents
      Loop
   code = InputBox("輸入查詢code", "code", code)
      For Each stock In Range([a2], [a65536].End(xlUp))
      .document.All("stk_code").Value = stock
      .document.All("auth_num").Value = code 'Cells(1, 1)

With Sheets("web")
.Cells.Delete
   .QueryTables.Add Connection:="URL;", Destination:=.Range("A1")
   DoEvents
With .QueryTables.Add(Connection:="URL;http://www.gretai.org.tw/web/stock/aftertrading/broker_trading/download_ALLCSV.php?curstk=" & stock & "&stk_date=" & 日期 & "&auth=" & code & "", Destination:=.[a1])
      .AdjustColumnWidth = False
      .WebFormatting = xlWebFormattingNone
      .WebDisableDateRecognition = False
      .Refresh BackgroundQuery:=False
End With

.Columns("A:A").TextToColumns Destination:=.Range("A1"), DataType:=xlDelimited, _
      TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
      Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
      :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
      Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1)), _
      TrailingMinusNumbers:=True
      If .[a4] = " " Then .Cells.Delete: GoTo a
End With
      If Sheets("web").[a4] = "驗證碼已逾期，請重新查詢" Then
      stock.Offset(, 2) = "ng"
      .Quit

      .Visible = True                                        '讓ie可見
      .Navigate "http://www.gretai.org.tw/web/stock/aftertrading/broker_trading/brokerBS.php?l=zh-tw"
      Do Until .ReadyState = 4             '等待ie完畢載入
         DoEvents
      Loop

      code = InputBox("輸入查詢code", "code", code)
            GoTo a
      End If
整頁下載 '資訊整理
a:
   Next
   End With
程序很亂相互參考一下!

作者: HSIEN6001 時間: 2014-12-16 20:09

回復 25# flask

.Columns("A:A").TextToColumns Destination:=.Range("A1"), DataType:=xlDelimited, _
      TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
      Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
      :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
      Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1)), _
      TrailingMinusNumbers:=True

請問這段怎麼應用,我也想要zip檔
可否給參考,謝謝

作者: HSIEN6001 時間: 2014-12-16 20:10

回復 24# joey0415

存檔位置自行修正
參考!
[attach]19831[/attach]

作者: GBKEE 時間: 2014-12-16 21:56

本帖最後由 GBKEE 於 2014-12-16 22:02 編輯

回復 28# HSIEN6001
還有 Workbooks.Open 可用

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
'日報表載入
CSV載入
Target = ""
Application.EnableEvents = True
End If
End With
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
Private Sub CSV載入()
Dim e As Object, A As Object, kDate As String, S As String
Application.EnableEvents = True
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
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
kDate = Format(Date, "emmdd")
Application.DisplayAlerts = False
With Workbooks.Open("http://www.gretai.org.tw/web/stock/aftertrading/broker_trading/download_ALLCSV.php?curstk=" & Range(證券代號) & "&stk_date=" & kDate & "&&auth=" & Range(驗證碼))
.SaveAs "D:\" & Range(證券代號)
With .Sheets(1)
.UsedRange.Range("G:K").SpecialCells(xlCellTypeConstants).Offset(1).Copy .Cells(.Rows.Count, 1).End(xlUp).Offset(1)
.UsedRange.Range("G:K").Clear
End With
.Close True
End With
Application.DisplayAlerts = True
MsgBox "證券代號 : " & Range(證券代號) & " CSV 載入完畢"
NN:
.Quit
End With
Set IE = Nothing
圖形更新
End Sub

複製代碼

作者: HSIEN6001 時間: 2014-12-17 01:10

回復 25# flask

我已經看懂了,太厲害了
真的很快!!謝謝

作者: HSIEN6001 時間: 2014-12-17 01:13

回復 29# GBKEE

版大 Workbook open 匯入CSV的方式 , 收下囉!謝謝~

作者: HSIEN6001 時間: 2014-12-17 17:50

回復 29# GBKEE
您好,這裡一直出現缺 With 不知道哪裡要修改
麻煩幫忙校正問題

Sub 下載CSV()
Dim path As String, 日期 As String, URL As String, 代號
path = "C:\myStock\"
日期 = Format(Date, "emmdd")
Dim Rng As Range
AA:
Set Rng = [C:C].Find("NG", , , xlWhole)
Sheets("下載依據").Activate
With CreateObject("InternetExplorer.application")
.Visible = True
.navigate "http://www.gretai.org.tw/web/stock/aftertrading/broker_trading/brokerBS.php?l=zh-tw"
Do Until .readyState = 4
DoEvents
Loop
驗證碼 = InputBox("輸入查詢驗證碼", "驗證碼", code) '驗證碼 = InputBox
For Each 代號 In Range(Rng.Offset(0, -2), [E65536].End(xlUp))
.document.all("stk_code").Value = 代號
.document.all("auth_num").Value = 驗證碼
'**** 直接下載CSV ****
Dim xml As Object
Dim stream
Set xml = CreateObject("Microsoft.XMLHTTP")
Set stream = CreateObject("ADODB.stream")
'GET http://www.gretai.org.tw/web/stock/aftertrading/broker_trading/download_ALLCSV.php?curstk=8069&stk_date=1031215&auth=驗證碼
URL = "http://www.gretai.org.tw/web/stock/aftertrading/broker_trading/download_ALLCSV.php?curstk=" & 代號 & "&stk_date=" & 日期 & "&auth=" & 驗證碼
xml.Open "GET", URL, 0
xml.send
With stream
.Type = 1
.Open
.write xml.responseBody
'**** 判斷讀取資料 ****************************************************************
If .document.body.Innertext Like "*該日無交易資訊*" Then
GoTo NN 'Goto 下一個
ElseIf .document.body.Innertext Like "*驗證碼錯誤，請重新查詢*" Then
Sheets("下載依據").Range("C:C").Delete '清除舊的NG記號
代號.Offset(, 2) = "NG" '新增斷點
.Quit '關閉 IE 視窗
GoTo AA
ElseIf .document.body.Innertext Like "*驗證碼已逾期，請重新查詢*" Then
Sheets("下載依據").Range("C:C").Delete '清除舊的NG記號
代號.Offset(, 2) = "NG" '新增斷點
.Quit '關閉 IE 視窗
GoTo AA
'***** 判斷讀取資料 End *************************************************************
.SaveToFile (path & 代號 & ".csv")
.Close
End With
NN:
Next
.Quit '關閉 IE 視窗
End With
Range("C2") = "NG" '重新作記號,方便下回下載
End Sub

複製代碼

作者: GBKEE 時間: 2014-12-18 05:45

回復 32# HSIEN6001

'***** 判斷讀取資料 End *************************************************************
End If '沒有With 少這 End If

複製代碼

但這程式尚有缺失需修改.

Set Rng = [C:C].Find("NG", , , xlWhole) '找不時的處置???
For Each 代號 In Range(Rng.Offset(0, -2), [E65536].End(xlUp)) '須在前面
With CreateObject("InternetExplorer.application") '在For Each 代號迴圈內
'少掉查詢按鍵
if ....
'這段 IF 判斷要放在
End If
沒有dir檢查存檔之檔案是否存在
.SaveToFile (path & 代號 & ".csv")

複製代碼

作者: HSIEN6001 時間: 2014-12-18 08:44

回復 33# GBKEE

出現執行階段錯誤'438 , 物件不支援此屬性或方法
跟這一段判斷式有關,不知道該怎麼改 ?
沒判斷內容,會下載到空值

.write xml.responseBody
'**** 判斷讀取資料 ****************************************************************
If .document.body.Innertext Like "*該日無交易資訊*" Then
GoTo NN 'Goto 下一個
ElseIf .document.body.Innertext Like "*驗證碼錯誤，請重新查詢*" Then
'代號.Offset(, 2) = "NG"
GoTo AA ''視窗不關閉 & 重新輸入驗證碼 & 代號
ElseIf .document.body.Innertext Like "*驗證碼已逾期，請重新查詢*" Then
Sheets("下載依據").Range("F:F").Delete '清除舊的NG記號
代號.Offset(, 1) = "NG" '在隔壁第1欄位標註 "NG" , 方便重新抓取時,避開已經下載的資料
.Quit '關閉 IE 視窗
GoTo AA ''視窗重新開啟 & 重新輸入驗證碼 & 代號
End If
'***** 判斷讀取資料 End *************************************************************

複製代碼

作者: GBKEE 時間: 2014-12-18 12:33

回復 34# HSIEN6001

With stream '在這With下
.Type = 1
.Open
.write xml.responseBody
'**** 判斷讀取資料 ****************************************************************
If .document.body.Innertext Like "*該日無交易資訊*" Then
'******* .document 是IE的子物件******
GoTo NN 'Goto 下一個

複製代碼

作者: HSIEN6001 時間: 2014-12-18 14:53

回復 35# GBKEE

如果用 .responseText
怎麼寫,達到 IF ...Then...ElseIF.... EndIf

作者: kenkid 時間: 2014-12-28 15:48

太強了...我正好想破頭了T_T...沒想到有大大分享解決辦法^^

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)