- 帖子
- 151
- 主題
- 1
- 精華
- 0
- 積分
- 197
- 點名
- 14
- 作業系統
- windwos 7
- 軟體版本
- 64bit
- 閱讀權限
- 20
- 註冊時間
- 2017-5-29
- 最後登錄
- 2024-4-18
|
本帖最後由 quickfixer 於 2022-9-10 01:08 編輯
回復 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
- Sub Get_tdcc()
-
-
- Dim Html As Object, GetXml As Object, r As Integer, url_a As String, temp() As String, ttt As Double
- Dim SYNCHRONIZER_TOKEN As String, firDate, StockID As String, StockName As String
- Set Html = CreateObject("htmlfile")
- Set GetXml = CreateObject("msxml2.xmlhttp")
-
-
- ttt = Timer
- Application.ScreenUpdating = False
- On Error GoTo redownload
-
- 'StockID = "2002"
- StockID = "2330"
-
- retry1:
- With GetXml
- .Open "GET", "https://www.tdcc.com.tw/portal/zh/smWeb/qryStock", False
- .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
- .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; Win64; x64; rv:102.0) Gecko/20100101 Firefox/102.0"
- .send
-
- Html.body.innerhtml = .responsetext
- firDate = Split(Trim(Html.getElementById("scaDate").innertext), " ")
-
- If IsEmpty(firDate) = True Then
- Debug.Print "get day error"
- Delaytick (0.5)
- r = r + 1
- Debug.Print r
- If r > 3 Then
- MsgBox "線上日期無法更新，請稍後重試", vbOKOnly, "Error"
- Exit Sub
- End If
- If Err.Number <> 0 Then
- Debug.Print Err.Description
- End If
- On Error GoTo -1
- Err.Clear
- GoTo retry1
- End If
-
- End With
-
-
-
-
- retry2:
-
- For d = 0 To 9 '近十周
-
- With GetXml
- .Open "GET", "https://www.tdcc.com.tw/portal/zh/smWeb/qryStock", False
- .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
- .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; Win64; x64; rv:102.0) Gecko/20100101 Firefox/102.0"
- .send
-
- Html.body.innerhtml = .responsetext
- SYNCHRONIZER_TOKEN = Html.getElementById("SYNCHRONIZER_TOKEN").Value
-
-
- End With
-
-
- 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="
-
- With GetXml
- .Open "POST", "https://www.tdcc.com.tw/portal/zh/smWeb/qryStock", False
- .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
- .setRequestHeader "Referer", "https://www.tdcc.com.tw/portal/zh/smWeb/qryStock"
- .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; Win64; x64; rv:102.0) Gecko/20100101 Firefox/102.0"
- .send (url_a)
-
- Html.body.innerhtml = .responsetext
-
- If d = 0 Then
- StockName = Replace(Split(Split(.responsetext, "證券代號：")(1), "</p>")(0), Chr(10), "")
- StockName = "證券代號：" & Replace(Replace(StockName, " ", ""), "<br>", " ")
- Sheets("工作表1").Cells.Clear
- Sheets("工作表1").Columns.ColumnWidth = 16
- Sheets("工作表1").Range("a1") = StockName
- End If
-
- Set Table = Html.all.tags("table")(1).Rows
-
- If Table(1).Cells(0).innertext = "查無此資料" Then
- Delaytick (0.3)
- r = r + 1
- If r > 5 Then
- MsgBox StockID & vbNewLine & firDate & "，此日期無資料或連線異常，請稍後再試", vbOKOnly, "Error"
- Set Table = Nothing
- Set Html = Nothing
- Set GetXml = Nothing
- Application.ScreenUpdating = True
- Exit Sub
- End If
- GoTo retry2
- End If
-
-
- ReDim temp(1 To Table.Length - 1, Table(2).Cells.Length - 1)
-
- With Sheets("工作表1")
-
-
- For i = 1 To Table.Length - 1
-
- For j = 0 To Table(i).Cells.Length - 1
- temp(i, j) = Table(i).Cells(j).innertext
- Next j
- Next i
-
- .Range("a2").Offset(, d * 5) = firDate(d)
- .Range("a3:e3").Offset(, d * 5) = Array("序", "持股", "人數", "股數", "比例%")
- .Range(.Cells(4, 1), .Cells(i + 2, 5)).Offset(, d * 5) = temp()
-
- End With
- End With
-
- Next d
-
- Set Table = Nothing
- Set Html = Nothing
- Set GetXml = Nothing
- Application.ScreenUpdating = True
-
- Debug.Print Timer - ttt
- Exit Sub
-
- redownload:
- r = r + 1
- Debug.Print "http 404"
- Delaytick (1.3)
- If r > 3 Then
- MsgBox "連線異常，請稍後再試", vbOKOnly, "Error"
-
- 'Stop 'debug
-
- Set Table = Nothing
- Set Html = Nothing
- Set GetXml = Nothing
- Application.ScreenUpdating = True
- Exit Sub
-
- End If
-
- If Err.Number <> 0 Then
- Debug.Print Err.Description
- End If
-
- On Error GoTo -1
- Err.Clear
-
- GoTo retry2
- End Sub
- Sub Delaytick(setdelay As Single)
-
- Dim StartTime As Double, NowTime As Double
- StartTime = Timer * 100
- setdelay = setdelay * 100
- Do
- NowTime = Timer * 100
- DoEvents
- Loop Until NowTime - StartTime > setdelay
-
- End Sub
|
|
發表於 2018-3-28 18:06
| 
