HSIEN6001

回復 24# joey0415

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

下載次數: 28

2014-12-16 20:10

HSIEN6001

回復 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檔
可否給參考,謝謝

flask

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
程序很亂相互參考一下!

flask

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來次就可下載完!

joey0415

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

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

謝謝啦

HSIEN6001

回復 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")
   
5. 
   
6. Dim path As String, url
   
7. path = "C:\"
   
8.     Dim 日期 As String
   
9.     日期 = "1031215"
   
10. 
    
11. 'GET http://www.gretai.org.tw/web/stock/aftertrading/broker_trading/download_ALLCSV.php?curstk=股票代號&stk_date=日期&auth=驗證碼
    
12. 
    
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

複製代碼

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

HSIEN6001

回復 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

複製代碼

joey0415

回復 19# GBKEE

請問在第一段的

If IE Is Nothing Then

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

HSIEN6001

回復 19# GBKEE

耶!成了

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

~感恩~

GBKEE

回復 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

複製代碼