1234
返回列表 上一主題 發帖

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

joey0415
　暱稱: joey0415

中學生Rank: 2

帖子
361 
主題
57 
精華
0 
積分
426 
點名
0  
作業系統
win7 
軟體版本
2003,2010 
閱讀權限
20 
性別
男 
註冊時間
2010-5-13 
最後登錄
2022-12-8 
21# 跳轉到 »
發表於 2014-12-16 13:05 | 只看該作者
回復 19# GBKEE

請問在第一段的

If IE Is Nothing Then

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

TOP

HSIEN6001

帖子
219 
主題
24 
精華
0 
積分
243 
點名
0  
作業系統
Windows10 
軟體版本
Office2016 
閱讀權限
20 
性別
女 
註冊時間
2012-4-18 
最後登錄
2022-2-7 

論壇榮譽勳章論壇贊助勳章
22#
發表於 2014-12-16 14:38 | 只看該作者
回復 21# joey0415

整段語法是這樣的 , 綜合 #2 & #9
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, IEx As Object
  3. Const 圖形 = "C:\驗證圖.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, 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.         UsedRange.Offset(6).Clear
  43.         Range("a" & k + 1) = S
  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 IEx = CreateObject("InternetExplorer.Application")
  52.         IEx.Navigate "about:Tabs"
  53.         Set A = .Document.all.tags("A")
  54.         單頁載入 .Document.all.tags("table")(0).outerHTML
  55.         [A6].Select
  56.         '********程式碼寫在工作表模組: Me 指這工作表模組
  57.         Me.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False, NoHTMLFormatting:=True
  58.         '****************************************
  59.         If A.Length = 459 Then
  60.             For i = 2 To 3
  61.                 單頁載入 .Document.all.tags("table")(i).outerHTML
  62.                 With Range("A" & Rows.Count).End(xlUp).Offset(1)
  63.                     .Select
  64.                     Me.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False, NoHTMLFormatting:=True
  65.                 End With
  66.             Next
  67.         Else
  68.             For k = 0 To A.Length - 1
  69.                 If Val(A(k).Innertext) >= 1 Then
  70.                     Debug.Print A(k).Innertext
  71.                     A(k).Click
  72.                     Do While .Busy Or .readyState <> 4: DoEvents: Loop
  73.                     Set A = .Document.all.tags("A")
  74.                     Do While .Busy Or .readyState <> 4: DoEvents: Loop
  75.                     For i = 2 To 3
  76.                         單頁載入 .Document.all.tags("table")(i).outerHTML
  77.                         With Range("A" & Rows.Count).End(xlUp).Offset(1)
  78.                             .Select
  79.                             Me.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False, NoHTMLFormatting:=True
  80.                         End With
  81.                     Next
  82.                 End If
  83.             Next
  84.         End If
  85.         IEx.Quit
  86.         Set IEx = Nothing
  87.         整理
  88. NN:
  89.         .Quit
  90.     End With
  91.     Set IE = Nothing
  92.     圖形更新
  93. End Sub
  94. Private Sub 單頁載入(S)
  95.     With IEx
  96.         .Document.body.innerHTML = S
  97.         .ExecWB 17, 2       '  Select All
  98.         .ExecWB 12, 2       '  Copy selection
  99.     End With
  100. End Sub
  101. Private Sub 整理()
  102.     On Error Resume Next
  103.     Application.EnableEvents = False
  104.     With UsedRange.Offset(10)
  105.         .Replace "序號", "=ex", xlWhole
  106.         .SpecialCells(xlCellTypeFormulas, xlErrors).EntireRow.Delete
  107.     End With
  108.     UsedRange(1).Select
  109.     Application.EnableEvents = True
  110. End Sub
  111. Private Sub Get_Ie()
  112.     Set IE = CreateObject("InternetExplorer.Application")
  113.     With IE
  114.        ' .Visible = True
  115.         '券商買賣證券日報表查詢系統（一般交易）
  116.         .Navigate "http://www.gretai.org.tw/web/stock/aftertrading/broker_trading/brokerBS.php?l=zh-tw"
  117.         Do While .Busy Or .readyState <> 4: DoEvents: Loop
  118.     End With
  119. End Sub
  120. Private Sub 圖形更新()
  121.     If IE Is Nothing Then Get_Ie
  122.     If Msg Then MsgBox "驗證圖 更新完畢"
  123.     Msg = False
  124.     With IE
  125.         .Refresh
  126.         Do While .Busy Or .readyState <> 4: DoEvents: Loop
  127.         網路圖片存檔 .Document.all.tags("IMG")(0).href
  128.     End With
  129.     Sheet1.Shapes("驗證圖").Fill.UserPicture 圖形    '
  130. End Sub
  131. Private Sub 網路圖片存檔(img As String)
  132.     Dim xml As Object     '用來取得網頁資料
  133.     Dim stream            'As ADODB.stream   '用來儲存二進位檔案
  134.     Set xml = CreateObject("Microsoft.XMLHTTP")
  135.     Set stream = CreateObject("ADODB.stream")
  136.     xml.Open "GET", img, 0
  137.     xml.send
  138.     With stream
  139.         .Open
  140.         .Type = 1
  141.         .write xml.ResponseBody
  142.         If Dir(圖形) <> "" Then Kill 圖形
  143.         .SaveToFile (圖形)
  144.         .Close
  145.     End With
  146. End Sub
複製代碼

TOP

HSIEN6001

帖子
219 
主題
24 
精華
0 
積分
243 
點名
0  
作業系統
Windows10 
軟體版本
Office2016 
閱讀權限
20 
性別
女 
註冊時間
2012-4-18 
最後登錄
2022-2-7 

論壇榮譽勳章論壇贊助勳章
23#
發表於 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=" & 驗證碼

我把表身匯入改成這段
  1.     Dim xml As Object     '用來取得網頁資料
  2.     Dim stream            'As ADODB.stream   '用來儲存二進位檔案
  3.     Set xml = CreateObject("Microsoft.XMLHTTP")
  4.     Set stream = CreateObject("ADODB.stream")

  6. Dim path As String, url
  7. path = "C:\"
  8.     Dim 日期 As String
  9.     日期 = "1031215"

  11. 'GET http://www.gretai.org.tw/web/stock/aftertrading/broker_trading/download_ALLCSV.php?curstk=股票代號&stk_date=日期&auth=驗證碼

  13.     url = "http://www.gretai.org.tw/web/stock/aftertrading/broker_trading/download_ALLCSV.php?curstk=" & Sheets("Sheet1").[F2] & "&stk_date=" & 日期 & "&auth=" & Sheets("Sheet1").[F4]
  14.         xml.Open "GET", url, 0
  15.         xml.send
  16.     With stream
  17.         .Type = 1
  18.         .Open
  19.         .write xml.responseBody
  20.         If Dir(path & Sheets("Sheet1").[F2] & ".csv") <> "" Then Kill (path & Sheets("Sheet1").[F2] & ".csv")
  21.         .SaveToFile (path & Sheets("Sheet1").[F2] & ".csv")
  22.         .Close
  23.     End With
複製代碼
非常謝謝您的指導!!
^__^

TOP

joey0415
　暱稱: joey0415

中學生Rank: 2

帖子
361 
主題
57 
精華
0 
積分
426 
點名
0  
作業系統
win7 
軟體版本
2003,2010 
閱讀權限
20 
性別
男 
註冊時間
2010-5-13 
最後登錄
2022-12-8 
24#
發表於 2014-12-16 18:20 | 只看該作者
回復 23# HSIEN6001
可不可分享一個做好的zip檔，方便研究嗎？

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

謝謝啦

TOP

flask

帖子
40 
主題
10 
精華
0 
積分
83 
點名
0  
作業系統
winxp 
軟體版本
office2003 
閱讀權限
20 
註冊時間
2011-6-3 
最後登錄
2020-10-1 
25#
發表於 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來次就可下載完!

TOP

flask

帖子
40 
主題
10 
精華
0 
積分
83 
點名
0  
作業系統
winxp 
軟體版本
office2003 
閱讀權限
20 
註冊時間
2011-6-3 
最後登錄
2020-10-1 
26#
發表於 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
程序很亂相互參考一下!

TOP

HSIEN6001

帖子
219 
主題
24 
精華
0 
積分
243 
點名
0  
作業系統
Windows10 
軟體版本
Office2016 
閱讀權限
20 
性別
女 
註冊時間
2012-4-18 
最後登錄
2022-2-7 

論壇榮譽勳章論壇贊助勳章
27#
發表於 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檔
可否給參考,謝謝

TOP

HSIEN6001

帖子
219 
主題
24 
精華
0 
積分
243 
點名
0  
作業系統
Windows10 
軟體版本
Office2016 
閱讀權限
20 
性別
女 
註冊時間
2012-4-18 
最後登錄
2022-2-7 

論壇榮譽勳章論壇贊助勳章
28#
發表於 2014-12-16 20:10 | 只看該作者
回復 24# joey0415

存檔位置自行修正
參考!
    下載CSV.rar (10 KB)

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
29#
發表於 2014-12-16 21:56 | 只看該作者
本帖最後由 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

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

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

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

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

TOP

HSIEN6001

帖子
219 
主題
24 
精華
0 
積分
243 
點名
0  
作業系統
Windows10 
軟體版本
Office2016 
閱讀權限
20 
性別
女 
註冊時間
2012-4-18 
最後登錄
2022-2-7 

論壇榮譽勳章論壇贊助勳章
30#
發表於 2014-12-17 01:10 | 只看該作者
回復 25# flask

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

TOP

        靜思自在 : 話多不如話少，話少不如話好。
1234
返回列表 上一主題