dino123

謝謝版主開版，程式我有拿來改後使用
但上星期(11109)集保的網站改版了
我自己改不出來抓取，能否改一下呢

quickfixer

回復 21# dino123

參考資料
    https://www.mobile01.com/topicdetail.php?f=511&t=4737630&p=125
    https://www.mobile01.com/topicdetail.php?f=511&t=4737630&p=126

下載 (44.73 KB)

2022-9-10 01:04

1. Sub Get_tdcc()
   
2.    
   
3.    
   
4.     Dim Html As Object, GetXml As Object, r As Integer, url_a As String, temp() As String, ttt As Double
   
5.     Dim SYNCHRONIZER_TOKEN As String, firDate, StockID As String, StockName As String
   
6.     Set Html = CreateObject("htmlfile")
   
7.     Set GetXml = CreateObject("msxml2.xmlhttp")
   
8.    
   
9.    
   
10.     ttt = Timer
    
11.     Application.ScreenUpdating = False
    
12.     On Error GoTo redownload
    
13. 
    
14.    
    
15.     'StockID = "2002"
    
16.     StockID = "2330"
    
17.    
    
18. retry1:
    
19. 
    
20.     With GetXml
    
21.         .Open "GET", "https://www.tdcc.com.tw/portal/zh/smWeb/qryStock", False
    
22.         .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    
23.         .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; Win64; x64; rv:102.0) Gecko/20100101 Firefox/102.0"
    
24.         .send
    
25.         
    
26.         Html.body.innerhtml = .responsetext
    
27.         firDate = Split(Trim(Html.getElementById("scaDate").innertext), " ")
    
28.         
    
29.         If IsEmpty(firDate) = True Then
    
30.            Debug.Print "get day error"
    
31.            Delaytick (0.5)
    
32.            r = r + 1
    
33.            Debug.Print r
    
34.            If r > 3 Then
    
35.                MsgBox "線上日期無法更新，請稍後重試", vbOKOnly, "Error"
    
36.                Exit Sub
    
37.            End If
    
38.            If Err.Number <> 0 Then
    
39.                Debug.Print Err.Description
    
40.            End If
    
41.            On Error GoTo -1
    
42.            Err.Clear
    
43.            GoTo retry1
    
44.         End If
    
45.         
    
46.     End With
    
47.    
    
48.    
    
49.    
    
50.    
    
51. retry2:
    
52.    
    
53.     For d = 0 To 9 '近十周
    
54.    
    
55.         With GetXml
    
56.             .Open "GET", "https://www.tdcc.com.tw/portal/zh/smWeb/qryStock", False
    
57.             .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    
58.             .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; Win64; x64; rv:102.0) Gecko/20100101 Firefox/102.0"
    
59.             .send
    
60.         
    
61.             Html.body.innerhtml = .responsetext
    
62.             SYNCHRONIZER_TOKEN = Html.getElementById("SYNCHRONIZER_TOKEN").Value
    
63.    
    
64.         
    
65.         End With
    
66.            
    
67.          
    
68.         url_a = "SYNCHRONIZER_TOKEN=" & SYNCHRONIZER_TOKEN & "&SYNCHRONIZER_URI=%2Fportal%2Fzh%2FsmWeb%2FqryStock&method=submit&firDate=" & firDate(d) & "&scaDate=" & firDate(d) & "&sqlMethod=StockNo&stockNo=" & StockID & "&stockName="
    
69.         
    
70.         With GetXml
    
71.             .Open "POST", "https://www.tdcc.com.tw/portal/zh/smWeb/qryStock", False
    
72.             .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    
73.             .setRequestHeader "Referer", "https://www.tdcc.com.tw/portal/zh/smWeb/qryStock"
    
74.             .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; Win64; x64; rv:102.0) Gecko/20100101 Firefox/102.0"
    
75.             .send (url_a)
    
76.             
    
77.             Html.body.innerhtml = .responsetext
    
78.         
    
79.             If d = 0 Then
    
80.                 StockName = Replace(Split(Split(.responsetext, "證券代號：")(1), "</p>")(0), Chr(10), "")
    
81.                 StockName = "證券代號：" & Replace(Replace(StockName, " ", ""), "<br>", " ")
    
82.                 Sheets("工作表1").Cells.Clear
    
83.                 Sheets("工作表1").Columns.ColumnWidth = 16
    
84.                 Sheets("工作表1").Range("a1") = StockName
    
85.             End If
    
86.                
    
87.             Set Table = Html.all.tags("table")(1).Rows
    
88.             
    
89.             If Table(1).Cells(0).innertext = "查無此資料" Then
    
90.                 Delaytick (0.3)
    
91.                 r = r + 1
    
92.                 If r > 5 Then
    
93.                     MsgBox StockID & vbNewLine & firDate & "，此日期無資料或連線異常，請稍後再試", vbOKOnly, "Error"
    
94.                     Set Table = Nothing
    
95.                     Set Html = Nothing
    
96.                     Set GetXml = Nothing
    
97.                     Application.ScreenUpdating = True
    
98.                     Exit Sub
    
99.                 End If
    
100.                 GoTo retry2
     
101.             End If
     
102.             
     
103.                
     
104.             ReDim temp(1 To Table.Length - 1, Table(2).Cells.Length - 1)
     
105.                
     
106.             With Sheets("工作表1")
     
107.                
     
108.             
     
109.                 For i = 1 To Table.Length - 1
     
110.                     
     
111.                     For j = 0 To Table(i).Cells.Length - 1
     
112.                         temp(i, j) = Table(i).Cells(j).innertext
     
113.                     Next j
     
114.                 Next i
     
115.             
     
116.                 .Range("a2").Offset(, d * 5) = firDate(d)
     
117.                 .Range("a3:e3").Offset(, d * 5) = Array("序", "持股", "人數", "股數", "比例%")
     
118.                 .Range(.Cells(4, 1), .Cells(i + 2, 5)).Offset(, d * 5) = temp()
     
119.             
     
120.             End With
     
121. 
     
122.         End With
     
123.    
     
124.     Next d
     
125.    
     
126.     Set Table = Nothing
     
127.     Set Html = Nothing
     
128.     Set GetXml = Nothing
     
129.     Application.ScreenUpdating = True
     
130.    
     
131.     Debug.Print Timer - ttt
     
132.     Exit Sub
     
133.    
     
134. redownload:
     
135.     r = r + 1
     
136.     Debug.Print "http 404"
     
137.     Delaytick (1.3)
     
138.     If r > 3 Then
     
139.        MsgBox "連線異常，請稍後再試", vbOKOnly, "Error"
     
140.       
     
141.        'Stop 'debug
     
142.       
     
143.        Set Table = Nothing
     
144.        Set Html = Nothing
     
145.        Set GetXml = Nothing
     
146.        Application.ScreenUpdating = True
     
147.        Exit Sub
     
148.    
     
149.     End If
     
150.    
     
151.     If Err.Number <> 0 Then
     
152.         Debug.Print Err.Description
     
153.     End If
     
154.    
     
155.     On Error GoTo -1
     
156.     Err.Clear
     
157.    
     
158.     GoTo retry2
     
159. 
     
160. 
     
161. End Sub
     
162. 
     
163. Sub Delaytick(setdelay As Single)
     
164.    
     
165.     Dim StartTime As Double, NowTime As Double
     
166.     StartTime = Timer * 100
     
167.     setdelay = setdelay * 100
     
168.     Do
     
169.       NowTime = Timer * 100
     
170.       DoEvents
     
171.     Loop Until NowTime - StartTime > setdelay
     
172.    
     
173. End Sub

複製代碼

dino123

回復 22# quickfixer


    感謝回復…但我後來用的抓法，好像不太一樣，我用WinHttp 似乎快很多。 我把我用的程式貼在下面新的一則貼文

dino123

我的程式，一次會抓取一年下來的TDCC 資料
不曉得這次改版後，我的程式那邊對應不到，

Sub GoTDCC1yr()
'
' GoTDCC1yr Macro
'
Dim TWYear, CEYear As String
    For m = 1 To 51
        Dim WinHttp As Object, DOM As Object, Table As Object
        Dim url As String, Title() As String, Stockid As String, weekDate As String
        Dim i As Integer, j As Integer

        TWYear = Sheets("三大法人").Cells(m, "O") '民國年日期
        CEYear = Sheets("三大法人").Cells(m, "P")  '西元年日期
        Sheets(TWYear).Activate
StartTDCC:
        Stock = Worksheets("三大法人").Range("M1").Value  '股票代碼
        weekDate = Sheets("三大法人").Cells(m, "P")   '西元年日期 tdcc 用西元年月日
        url = "https://www.tdcc.com.tw/portal/zh/smWeb/qryStock"  ' 改這樣是否正確？
        '  url = "https://www.tdcc.com.tw/smWeb/QryStockAjax.do"    原本url

        Set WinHttp = CreateObject("winhttp.winhttprequest.5.1")
        Set DOM = CreateObject("htmlfile")

        With WinHttp                                    '這裡不知如何改對應這次的改版
            .Open "POST", url, False
            .setrequestheader "Content-Type", "application/x-www-form-urlencoded"
            .send "scaDate=" & weekDate & "&clkStockNo=" & Stock & "&REQ_OPR=SELECT"
        
            If .Status = 200 Then
                DOM.body.innerHTML = .responsetext
            End If
        End With

        Set Table = DOM.getElementsByTagName("table")
        i = 1
        For Each tr In Table(6).Rows                                                     ' 還是回傳資料要改？
            j = 1
            For Each td In tr.Cells
                Sheets(TWYear).Cells(i, j) = td.innerText
                j = j + 1
            Next
            i = i + 1
        Next
   
        i = 2
        For Each tr In Table(7).Rows
            j = 1
            For Each td In tr.Cells
                Sheets(TWYear).Cells(i, j) = td.innerText
                j = j + 1
            Next
            i = i + 1
        Next
   
        Set Table = Nothing
        Set DOM = Nothing
        Set WinHttp = Nothing
              
    Next
   
End Sub

quickfixer

回復 24# dino123


現在send 2次,要多抓一次動態的key    SYNCHRONIZER_TOKEN
所以改版後下載時間會是改版前的2倍
你沒檔案我不知道cell內是什麼東西

22#  9改成51,就是1年
For d = 0 To 9 '近十周
For d = 0 To 51

quickfixer

回復 25# quickfixer


    訂正,不能用51,有時候是50
修正用ubound
For d = 0 To UBound(firDate)