返回列表 上一主題 發帖

請問如何將網頁的圖片存檔

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

為使VBA入門者,有實作經驗,故僅附上程式碼.



ThisWorkbook模組的程式碼
  1. Option Explicit
  2. Private Sub Workbook_Open()
  3.     Sheet1.Msg = True
  4.     Run "Sheet1.圖形更新"
  5. End Sub
  6. Private Sub Workbook_BeforeClose(Cancel As Boolean)
  7.     On Error Resume Next
  8.     If Not Sheet1.IE Is Nothing Then Sheet1.IE.Quit
  9. End Sub
複製代碼
Sheet1模組的程式碼
  1. Option Explicit
  2. Public IE As Object, Msg As Boolean
  3. Const 圖形 = "d:\驗證圖.jpg"
  4. Const 證券代號 = "F2"
  5. Const 驗證碼 = "F4"
  6. Private Sub Worksheet_Change(ByVal Target As Range)
  7.     Range(證券代號).Interior.ColorIndex = IIf(Range(證券代號).Value = "", 2, 36)
  8.     With Target.Cells(1)
  9.          If .Address(0, 0) = 驗證碼 Then .Interior.ColorIndex = IIf(Len(Trim(.Cells)) = 5, 36, 2)
  10.          If .Address(0, 0) = 驗證碼 And Len(Trim(.Cells)) = 5 And Range(證券代號).Value <> "" Then
  11.             If IE Is Nothing Then
  12.                 Target = ""
  13.                 Msg = True
  14.                 圖形更新
  15.                 Exit Sub
  16.             End If
  17.             Application.EnableEvents = False
  18.             日報表載入
  19.             Target = ""
  20.             Application.EnableEvents = True
  21.         End If
  22.     End With
  23. End Sub
  24. Private Sub 日報表載入()
  25.     Dim e As Object, a As Object, K  As Integer, i As Integer, ii As Integer, s As String
  26.     If IE Is Nothing Then
  27.         圖形更新
  28.         MsgBox "驗證圖已更新"
  29.         Exit Sub
  30.     End If
  31.     With IE
  32.         .Document.ALL.tags("INPUT")("stk_code").Value = Range(證券代號)
  33.         .Document.ALL.tags("INPUT")("auth_num").Value = Trim(Range(驗證碼))
  34.         Set a = .Document.ALL.tags("BUTTON")
  35.         For Each e In a
  36.             If Trim(e.innertext) = "查詢" And e.ID = "" Then
  37.             e.Click
  38.             Exit For
  39.             End If
  40.         Next
  41.         Do While .Busy Or .readyState <> 4: DoEvents: Loop
  42.         K = 6
  43.         UsedRange.Offset(6).Clear
  44.         If .Document.body.innertext Like "***該股票該日無交易資訊***" Then s = "***該股票該日無交易資訊***"
  45.         If .Document.body.innertext Like "***驗證碼錯誤,請重新查詢。***" Then s = "***驗證碼錯誤,請重新查詢。*** "
  46.         If s <> "" Then
  47.             Range("a" & K + 1) = s
  48.             MsgBox s
  49.             GoTo NN
  50.         End If
  51.         Set a = .Document.ALL.tags("table")(0)
  52.         For i = 0 To a.Rows.Length - 1
  53.             K = K + 1
  54.             For ii = 0 To a.Rows(i).Cells.Length - 1
  55.                 Cells(K, ii + 1) = a.Rows(i).Cells(ii).innertext
  56.             Next
  57.         Next
  58.         Set a = .Document.ALL.tags("table")(2)
  59.         K = K + 1
  60.         For i = 0 To a.Rows.Length - 1
  61.             K = K + 1
  62.             For ii = 0 To a.Rows(i).Cells.Length - 1
  63.                 Cells(K, ii + 1) = a.Rows(i).Cells(ii).innertext
  64.             Next
  65.         Next
  66.         Set a = .Document.ALL.tags("table")(3)
  67.         For i = 1 To a.Rows.Length - 1
  68.             K = K + 1
  69.             For ii = 0 To a.Rows(i).Cells.Length - 1
  70.                 Cells(K, ii + 1) = a.Rows(i).Cells(ii).innertext
  71.             Next
  72.         Next
  73.         MsgBox Range("d7") & " 日報表載入 完畢!!"
  74. NN:
  75.         .Quit
  76.     End With
  77.     Set IE = Nothing
  78.     圖形更新
  79. End Sub
  80. Private Sub Get_Ie()
  81.     Set IE = CreateObject("InternetExplorer.Application")
  82.     With IE
  83.        ' .Visible = True
  84.         '券商買賣證券日報表查詢系統(一般交易)
  85.         .Navigate "http://www.gretai.org.tw/web/stock/aftertrading/broker_trading/brokerBS.php?l=zh-tw"
  86.         Do While .Busy Or .readyState <> 4: DoEvents: Loop
  87.     End With
  88. End Sub
  89. Private Sub 圖形更新()
  90.     If IE Is Nothing Then Get_Ie
  91.     If Msg Then MsgBox "驗證圖 更新完畢"
  92.     Msg = False
  93.     With IE
  94.         .Refresh
  95.         Do While .Busy Or .readyState <> 4: DoEvents: Loop
  96.         網路圖片存檔 .Document.ALL.tags("IMG")(0).href
  97.     End With
  98.     Sheet1.Shapes("驗證圖").Fill.UserPicture 圖形    '
  99. End Sub
  100. Private Sub 網路圖片存檔(img As String)
  101.     Dim xml As Object     '用來取得網頁資料
  102.     Dim stream            'As ADODB.stream   '用來儲存二進位檔案
  103.     Set xml = CreateObject("Microsoft.XMLHTTP")
  104.     Set stream = CreateObject("ADODB.stream")
  105.     xml.Open "GET", img, 0
  106.     xml.send
  107.     With stream
  108.         .Open
  109.         .Type = 1
  110.         .write xml.ResponseBody
  111.         If Dir(圖形) <> "" Then Kill 圖形
  112.         .SaveToFile (圖形)
  113.         .Close
  114.     End With
  115. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

回復 5# flask
程式執行如圖



   
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

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

回復 8# wufonna
這錯誤是你將 IE關閉了
VBA按下重設,重新執行程式
  1. Private Sub Get_Ie()
  2.     Set IE = CreateObject("InternetExplorer.Application")
  3.     With IE
  4.        ' .Visible = True  *** 不顯示就是防止使用者關閉IE
  5.         '券商買賣證券日報表查詢系統(一般交易)
  6.         .Navigate "http://www.gretai.org.tw/web/stock/aftertrading/broker_trading/brokerBS.php?l=zh-tw"
  7.         Do While .Busy Or .readyState <> 4: DoEvents: Loop
  8.     End With
  9. End Sub
複製代碼


插入的圖片需使用繪圖的圖片
  1. 工作表1.Shapes("驗證圖").Fill.UserPicture 圖形
複製代碼
附檔插入的圖片沒改名稱 驗證圖
也可以使用 Shapes(索引值)->如Shapes(1)
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

回復 10# wufonna

你的附檔
插入的圖片需使用繪圖的圖片
一樣你的附檔 的圖片沒改名稱為 "驗證圖"
給你除錯程式碼
  1. Private Sub 圖形更新()
  2.    On Error GoTo ER
  3.     If IE Is Nothing Then Get_Ie
  4.     If Msg Then MsgBox "驗證圖 更新完畢"
  5.     Msg = False
  6.     With IE
  7.         .Refresh
  8.         Do While .Busy Or .readyState <> 4: DoEvents: Loop
  9.         網路圖片存檔 .Document.ALL.tags("IMG")(0).href
  10.     End With
  11.     MsgBox 工作表1.Shapes("驗證圖").Name
  12.    
  13.     工作表1.Shapes("驗證圖").Fill.UserPicture 圖形    '
  14.   Exit Sub
  15. ER:
  16.     MsgBox Err & vbLf & Err.Description
  17.     Stop
  18.     MsgBox 工作表1.Shapes(1).Name
  19.     Resume
  20. End Sub

複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

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






VBA修改
  1. With 工作表1
  2.     .Shapes(1).Name = "驗證圖"
  3.     .Shapes("驗證圖").Fill.UserPicture 圖形    '
  4. End With
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

回復 15# HSIEN6001

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

載入其他頁次
Dim IEx As Object  '工作表模組
  1. Private Sub 日報表載入()
  2.     Dim e As Object, A As Object, k  As Integer, i As Integer, S As String
  3.     If IE Is Nothing Then
  4.         圖形更新
  5.         MsgBox "驗證圖已更新"
  6.         Exit Sub
  7.     End If
  8.     With IE
  9.         .Document.all.tags("INPUT")("stk_code").Value = Range(證券代號)
  10.         .Document.all.tags("INPUT")("auth_num").Value = Trim(Range(驗證碼))
  11.         Set A = .Document.all.tags("BUTTON")
  12.         For Each e In A
  13.             If Trim(e.Innertext) = "查詢" And e.ID = "" Then
  14.             e.Click
  15.             Exit For
  16.             End If
  17.         Next
  18.         Do While .Busy Or .readyState <> 4: DoEvents: Loop
  19.         UsedRange.Offset(6).Clear
  20.         Range("a" & k + 1) = S
  21.         If .Document.body.Innertext Like "***該股票該日無交易資訊***" Then S = "***該股票該日無交易資訊***"
  22.         If .Document.body.Innertext Like "***驗證碼錯誤,請重新查詢。***" Then S = "***驗證碼錯誤,請重新查詢。*** "
  23.         If S <> "" Then
  24.             Range("a" & k + 1) = S
  25.             MsgBox S
  26.             GoTo NN
  27.         End If
  28.         Set IEx = CreateObject("InternetExplorer.Application")
  29.         IEx.Navigate "about:Tabs"
  30.         Set A = .Document.all.tags("A")
  31.         單頁載入 .Document.all.tags("table")(0).outerHTML
  32.         [A6].Select
  33.         '********程式碼寫在工作表模組: Me 指這工作表模組
  34.         Me.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False, NoHTMLFormatting:=True
  35.         '****************************************
  36.         If A.Length = 459 Then
  37.             For i = 2 To 3
  38.                 單頁載入 .Document.all.tags("table")(i).outerHTML
  39.                 With Range("A" & Rows.Count).End(xlUp).Offset(1)
  40.                     .Select
  41.                     Me.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False, NoHTMLFormatting:=True
  42.                 End With
  43.             Next
  44.         Else
  45.             For k = 0 To A.Length - 1
  46.                 If Val(A(k).Innertext) >= 1 Then
  47.                     Debug.Print A(k).Innertext
  48.                     A(k).Click
  49.                     Do While .Busy Or .readyState <> 4: DoEvents: Loop
  50.                     Set A = .Document.all.tags("A")
  51.                     Do While .Busy Or .readyState <> 4: DoEvents: Loop
  52.                     For i = 2 To 3
  53.                         單頁載入 .Document.all.tags("table")(i).outerHTML
  54.                         With Range("A" & Rows.Count).End(xlUp).Offset(1)
  55.                             .Select
  56.                             Me.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False, NoHTMLFormatting:=True
  57.                         End With
  58.                     Next
  59.                 End If
  60.             Next
  61.         End If
  62.         IEx.Quit
  63.         Set IEx = Nothing
  64.         整理
  65. NN:
  66.         .Quit
  67.     End With
  68.     Set IE = Nothing
  69.     圖形更新
  70. End Sub
  71. Private Sub 單頁載入(S)
  72.     With IEx
  73.         .Document.body.innerHTML = S
  74.         .ExecWB 17, 2       '  Select All
  75.         .ExecWB 12, 2       '  Copy selection
  76.     End With
  77. End Sub
  78. Private Sub 整理()
  79.     On Error Resume Next
  80.     Application.EnableEvents = False
  81.     With UsedRange.Offset(10)
  82.         .Replace "序號", "=ex", xlWhole
  83.         .SpecialCells(xlCellTypeFormulas, xlErrors).EntireRow.Delete
  84.     End With
  85.     UsedRange(1).Select
  86.     Application.EnableEvents = True
  87. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

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

回復 28# HSIEN6001
還有 Workbooks.Open 可用
  1. Option Explicit
  2. Public IE As Object, Msg As Boolean
  3. Const 圖形 = "d:\驗證圖.jpg"
  4. Const 證券代號 = "F2"
  5. Const 驗證碼 = "F4"
  6. Private Sub Worksheet_Change(ByVal Target As Range)
  7.     Range(證券代號).Interior.ColorIndex = IIf(Range(證券代號).Value = "", 2, 36)
  8.     With Target.Cells(1)
  9.          If .Address(0, 0) = 驗證碼 Then .Interior.ColorIndex = IIf(Len(Trim(.Cells)) = 5, 36, 2)
  10.          If .Address(0, 0) = 驗證碼 And Len(Trim(.Cells)) = 5 And Range(證券代號).Value <> "" Then
  11.             If IE Is Nothing Then
  12.                 Target = ""
  13.                 Msg = True
  14.                 圖形更新
  15.                 Exit Sub
  16.             End If
  17.             Application.EnableEvents = False
  18.             '日報表載入
  19.           CSV載入
  20.             Target = ""
  21.             Application.EnableEvents = True
  22.         End If
  23.     End With
  24. End Sub

  25. Private Sub Get_Ie()
  26.     Set IE = CreateObject("InternetExplorer.Application")
  27.     With IE
  28.         .Visible = True
  29.         '券商買賣證券日報表查詢系統(一般交易)
  30.         .Navigate "http://www.gretai.org.tw/web/stock/aftertrading/broker_trading/brokerBS.php?l=zh-tw"
  31.         Do While .Busy Or .readyState <> 4: DoEvents: Loop
  32.     End With
  33. End Sub

  34. Private Sub 圖形更新()
  35.     If IE Is Nothing Then Get_Ie
  36.     If Msg Then MsgBox "驗證圖 更新完畢"
  37.     Msg = False
  38.     With IE
  39.         .Refresh
  40.         Do While .Busy Or .readyState <> 4: DoEvents: Loop
  41.         網路圖片存檔 .Document.all.tags("IMG")(0).href
  42.     End With
  43.     Sheet1.Shapes("驗證圖").Fill.UserPicture 圖形    '
  44. End Sub

  45. Private Sub 網路圖片存檔(img As String)
  46.     Dim xml As Object     '用來取得網頁資料
  47.     Dim stream            'As ADODB.stream   '用來儲存二進位檔案
  48.     Set xml = CreateObject("Microsoft.XMLHTTP")
  49.     Set stream = CreateObject("ADODB.stream")
  50.     xml.Open "GET", img, 0
  51.     xml.send
  52.     With stream
  53.         .Open
  54.         .Type = 1
  55.         .write xml.responseBody
  56.         If Dir(圖形) <> "" Then Kill 圖形
  57.         .SaveToFile (圖形)
  58.         .Close
  59.     End With
  60. End Sub

  61. Private Sub CSV載入()
  62.     Dim e As Object, A As Object, kDate As String, S As String
  63.     Application.EnableEvents = True
  64.     If IE Is Nothing Then
  65.         圖形更新
  66.         MsgBox "驗證圖已更新"
  67.         Exit Sub
  68.     End If
  69.     With IE
  70.         .Document.all.tags("INPUT")("stk_code").Value = Range(證券代號)
  71.         .Document.all.tags("INPUT")("auth_num").Value = Trim(Range(驗證碼))
  72.         Set A = .Document.all.tags("BUTTON")
  73.         For Each e In A
  74.             If Trim(e.Innertext) = "查詢" And e.ID = "" Then
  75.             e.Click
  76.             Exit For
  77.             End If
  78.         Next
  79.         Do While .Busy Or .readyState <> 4: DoEvents: Loop
  80.         If .Document.body.Innertext Like "***該股票該日無交易資訊***" Then S = "***該股票該日無交易資訊***"
  81.         If .Document.body.Innertext Like "***驗證碼錯誤,請重新查詢。***" Then S = "***驗證碼錯誤,請重新查詢。*** "
  82.         If S <> "" Then
  83.             'Range("a" & k + 1) = S
  84.             MsgBox S
  85.             GoTo NN
  86.         End If
  87.         kDate = Format(Date, "emmdd")
  88.         Application.DisplayAlerts = False
  89.         With Workbooks.Open("http://www.gretai.org.tw/web/stock/aftertrading/broker_trading/download_ALLCSV.php?curstk=" & Range(證券代號) & "&stk_date=" & kDate & "&&auth=" & Range(驗證碼))
  90.             .SaveAs "D:\" & Range(證券代號)
  91.             With .Sheets(1)
  92.                 .UsedRange.Range("G:K").SpecialCells(xlCellTypeConstants).Offset(1).Copy .Cells(.Rows.Count, 1).End(xlUp).Offset(1)
  93.                 .UsedRange.Range("G:K").Clear
  94.             End With
  95.             .Close True
  96.         End With
  97.         Application.DisplayAlerts = True
  98.         MsgBox "證券代號 : " & Range(證券代號) & " CSV 載入完畢"
  99. NN:
  100.         .Quit
  101.     End With
  102.     Set IE = Nothing
  103.     圖形更新
  104. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

回復 32# HSIEN6001
  1.     '***** 判斷讀取資料  End *************************************************************
  2.             End If  '沒有With 少這 End If
複製代碼
但這程式尚有缺失需修改.

  1. Set Rng = [C:C].Find("NG", , , xlWhole)  '找不時的處置???
  2. For Each 代號 In Range(Rng.Offset(0, -2), [E65536].End(xlUp)) '須在前面
  3.         With CreateObject("InternetExplorer.application") '在For Each 代號 迴圈內
  4.          
  5.          '少掉查詢按鍵
  6.          if ....
  7.          '這段 IF 判斷要放在
  8.        End If   

  9.        沒有dir檢查 存檔之檔案是否存在
  10.          .SaveToFile (path & 代號 & ".csv")
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

回復 34# HSIEN6001
  1.   With stream   '在這With下
  2.                .Type = 1
  3.                 .Open
  4.                 .write xml.responseBody
  5.                 '**** 判斷讀取資料   ****************************************************************
  6.                 If .document.body.Innertext Like "*該日無交易資訊*" Then
  7.                  '*******  .document 是IE的子物件******
  8.                     GoTo NN  'Goto 下一個
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

        靜思自在 : 人事的艱難與琢磨,就是一種考驗。
返回列表 上一主題