a127a20005630 wrote:
想請問 最新的股權分散表網頁又更新了嗎 我的EXCEL好卡 黃色部分 EXCEL一職跳出 錯誤
有人可以幫忙解讀嗎 ".send url_a" 一直出現錯誤
下列是我之前在461樓抓取的語法...(恕刪)
是的，改版中 or 增加擋ip功能
這是449樓範例，如果是用我寫的程式碼，就不用貼出來，說幾樓就好了
自己寫的再貼出來，或是上傳檔案
晚點再修改範例
修改程式碼避免下載線上資料時出錯
(下載在資料庫中的不受影響，查詢速度不變)
手動新增access中未列入的股票代號方式，請參考969樓
'===ThisWorkbook======================================
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.DisplayAlerts = False
ActiveWorkbook.Save
Application.DisplayAlerts = True
End Sub
Private Sub Workbook_Open()
Sheets("工作表1").Buttons("TDCC_day").Visible = False
Call Checkdb_GetPath
Call Update_TDCC_day
Call addlistbox
Call Manually
End Sub
'=========================================
'===Module1====================================
Public Const DBname As String = "stock.accdb"
Global Target As String, Stockid As String, Stockname As String, Use_Combo_Changeid As Boolean
Sub Manually()
Dim LastRow As Integer, online1 As Integer, online2 As Integer, Crange As Range, Combo_Select, idtemp As String
If Use_Combo_Changeid = False Then
LastRow = Sheets("常用股票").Range("a1").CurrentRegion.Rows.Count
If LastRow > 1 Then
Set Crange = Sheets("常用股票").Range("a1", Sheets("常用股票").Range("a1").End(xlDown))
Else
Set Crange = Sheets("常用股票").Range("a1")
End If
idtemp = UCase(InputBox("請輸入證券代號"))
If idtemp = "" Then Exit Sub
If CheckStockId(idtemp) = True Then
Stockid = idtemp
Combo_Select = Application.Match(Stockid, Crange, 0)
If IsError(Combo_Select) Then
LastRow = LastRow + 1
Sheets("常用股票").Cells(LastRow, 1) = Stockid
Combo_Select = LastRow - 1
Else
Combo_Select = Combo_Select - 1
End If
Else
MsgBox "股票代號錯誤，請重新輸入", vbOKOnly, "Error"
Exit Sub
End If
Call AddComboData(LastRow, Combo_Select)
End If
Use_Combo_Changeid = False
With Sheets("工作表1")
.Columns("C:N").ClearContents
Call Get_Offline_Data
If .Cells(2, 3) = "*" And .Cells(2, 8) = "*" Then
Debug.Print "all offline"
Call Get_Offline_Stockname
Else
If .Cells(2, 3) = "" Then online1 = 1 Else online1 = 2
If .Cells(2, 8) = "" Then online2 = 2 Else online2 = 1
If online1 = 1 And online2 = 2 Then Debug.Print "all online" Else Debug.Print "1 online + 1 offline"
Call Get_Online_Data(online1, online2) 'save to access
End If
End With
Call TypeSetting
End Sub
Sub Get_Offline_Data()
ttt = Timer
If Stockid = "" Or Stockid = "股票代號" Then Exit Sub
Dim DB As Object, RS As Object, lastday As String, day(1 To 2) As String, k As Integer, Rsql As String
Set GetXml = CreateObject("msxml2.xmlhttp")
Set DB = CreateObject("ADODB.Connection")
Set RS = CreateObject("ADODB.Recordset")
DB.Open "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & Target & ";"
Application.ScreenUpdating = False
With Sheets("工作表1")
day(1) = .ListBoxes("list_0").List(.ListBoxes("list_0"))
day(2) = .ListBoxes("list_1").List(.ListBoxes("list_1"))
For k = 1 To 2
Rsql = "SELECT 序,持股,人數,股數,比例 from " & Stockid & " WHERE 日期='" & day(k) & "'"
RS.Open Rsql, DB, 3, 3
Debug.Print RS.RecordCount
If RS.RecordCount <> 0 Then
.Cells(2, 3 + ((k - 1) * 5)) = "*"
.Cells(4, 3 + ((k - 1) * 5)).CopyFromRecordset RS
End If
RS.Close
Next k
End With
With Sheets("工作表1")
.Select
.Cells(2, 4) = day(1)
.Cells(2, 9) = day(2)
End With
DB.Close
Set RS = Nothing
Set DB = Nothing
Debug.Print "Get_Offline_Data", Timer - ttt
Application.ScreenUpdating = True
End Sub
Sub Get_Online_Data(online1 As Integer, online2 As Integer) 'save to access
'====for debug ======
'Target = ThisWorkbook.Path & "\" & "stock.accdb"
'====================
ttt = Timer
If Stockid = "" Or Stockid = "股票代號" Then Exit Sub
Dim HTMLsourcecode As Object, GetXml As Object, day(1 To 2) As String, DB As Object, sql As String, openDB As String, r As Integer, url_a As String, temp() As String, Combo_Select As Integer, Combo_Text As String
Set HTMLsourcecode = CreateObject("htmlfile")
Set GetXml = CreateObject("msxml2.xmlhttp")
Set DB = CreateObject("ADODB.Connection")
openDB = "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & Target & ";"
DB.Open openDB
Application.ScreenUpdating = False
day(1) = Sheets("工作表1").ListBoxes("list_0").List(Sheets("工作表1").ListBoxes("list_0"))
day(2) = Sheets("工作表1").ListBoxes("list_1").List(Sheets("工作表1").ListBoxes("list_1"))
For k = online1 To online2
r = 0
retry2:
On Error GoTo redownload
url_a = "scaDates=" & day(k) & "&scaDate=" & day(k) & "&SqlMethod=StockNo&StockNo=" & Stockid & "&StockName=&REQ_OPR=SELECT&clkStockNo=" & Stockid & "&clkStockName="
With GetXml
.Open "POST", "https://www.tdcc.com.tw/smWeb/QryStockAjax.do", False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.setRequestHeader "Referer", "http://www.tdcc.com.tw/smWeb/QryStock.jsp"
.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
.send (url_a)
HTMLsourcecode.body.innerhtml = .responsetext
If InStr(HTMLsourcecode.body.innerhtml, "Your request timed out") > 0 Then
Debug.Print "timeout"
Delaytick (1.3)
r = r + 1
GoTo retry2
End If
Stockname = Split(HTMLsourcecode.all.tags("table")(6).Rows(0).innertext, "資料日期")(0)
Set Table = HTMLsourcecode.all.tags("table")(7).Rows
If Table(1).Cells(0).innertext = "無此資料" Then
Delaytick (0.05)
r = r + 1
If r > 10 Then
MsgBox day(k) & "此日期無資料", vbOKOnly, "Error"
If day(1) <> day(2) Then
sql = "INSERT INTO " & Stockid & _
" (日期,序,持股) VALUES " & _
"('" & day(k) & "','" & "1" & "','" & "無此資料" & "')"
DB.Execute sql
End If
GoTo getnextday
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
If day(1) <> day(2) Then
sql = "INSERT INTO " & Stockid & _
" (日期,序,持股,人數,股數,比例) VALUES " & _
"('" & day(k) & "','" & temp(i, 0) & "','" & temp(i, 1) & "','" & temp(i, 2) & "','" & temp(i, 3) & "','" & temp(i, 4) & "')"
DB.Execute sql
End If
Next i
.Range(.Cells(4, 3 + ((k - 1) * 5)), .Cells(i + 2, 7 + ((k - 1) * 5))) = temp()
End With
End With
getnextday:
Next k
With Sheets("工作表1")
.Select
.Cells(2, 4) = day(1)
.Cells(2, 9) = day(2)
End With
DB.Close
Set DB = Nothing
Set Table = Nothing
Set HTMLsourcecode = 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"
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 TypeSetting()
Application.ScreenUpdating = False
With Sheets("工作表1")
.Select
.Range("c3:n3") = Array("序", "持股", "人數", "股數", "比例%", "序", "持股", "人數", "股數", "比例%", "人數變化", "股數變化")
.Cells(4, 13).FormulaR1C1 = "=RC[-3]-RC[-8]"
.Cells(4, 14).FormulaR1C1 = "=RC[-3]-RC[-8]"
.Range("M4:N4").AutoFill Destination:=Range("M4:N18"), Type:=xlFillDefault
.Range("C3:N25").HorizontalAlignment = xlRight
.Range("D3:D25,I3:I25").HorizontalAlignment = xlLeft
Call SetFormatCondition
.Cells.Font.Size = "10"
.Columns.AutoFit
.Columns("A:B").ColumnWidth = 15
.Columns("M:N").NumberFormatLocal = "#,##0_ "
.Range("c:c,h:h").ColumnWidth = 3
.Range("d:d,i:i").ColumnWidth = 18
.Range("e:e,j:j").ColumnWidth = 10
.Range("f:f,k:k").ColumnWidth = 15
.Range("g:g,l:l").ColumnWidth = 6
.Cells(1, 4) = Stockname ' debug
.Cells(1, 1).Select
End With
Application.ScreenUpdating = True
End Sub
Sub Get_Offline_Stockname()
ttt = Timer
Dim DB As Object, RS As Object
Set DB = CreateObject("ADODB.Connection")
Set RS = CreateObject("ADODB.Recordset")
DB.Open "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & Target & ";"
RS.Open "SELECT 代號,名稱 FROM 股票清單 WHERE 代號='" & Stockid & "'", DB, 3, 3
Stockname = "證券代號：" & RS.Fields(0) & " 證券名稱：" & RS.Fields(1)
RS.Close
DB.Close
Set RS = Nothing
Set DB = Nothing
Debug.Print "get_offline_stockname", Timer - ttt
End Sub
Function CheckStockId(id As String) As Boolean
ttt = Timer
Dim DB As Object, RS As Object
Set DB = CreateObject("ADODB.Connection")
Set RS = CreateObject("ADODB.Recordset")
DB.Open "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & Target & ";"
RS.Open "SELECT 代號,名稱 FROM 股票清單 WHERE 代號='" & UCase(id) & "'", DB, 3, 3
If RS.RecordCount = 0 Then
CheckStockId = False
Debug.Print "無此代號", Timer - ttt
Stockname = ""
Else
CheckStockId = True
Debug.Print "代號正確", Timer - ttt
Stockname = "證券代號：" & RS.Fields(0) & " 證券名稱：" & RS.Fields(1)
End If
RS.Close
DB.Close
Set RS = Nothing
Set DB = Nothing
Debug.Print "checkstockid", Timer - ttt
End Function
Sub SetFormatCondition()
Dim Crange As Range, C1 As FormatCondition, C2 As FormatCondition
Set Crange = Sheets("工作表1").Range("m4", Sheets("工作表1").Range("n4").End(xlDown))
Crange.FormatConditions.Delete
Crange.Font.Bold = True
Set C1 = Crange.FormatConditions.Add(xlCellValue, xlGreater, "=0")
C1.Font.Color = vbRed
Set C2 = Crange.FormatConditions.Add(xlCellValue, xlLess, "=0")
C2.Font.Color = -11489280
Set Crange = Nothing
End Sub
Sub addlistbox()
'====for debug ======
'Target = ThisWorkbook.Path & "\" & "stock.accdb"
'====================
ttt = Timer
Dim DB As Object, RS As Object, lastday As String, list_0, list_1, Combo_0, temp()
Set DB = CreateObject("ADODB.Connection")
Set RS = CreateObject("ADODB.Recordset")
On Error Resume Next
Sheets("工作表1").Columns("C:N").ClearContents
Application.ScreenUpdating = False
DB.Open "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & Target & ";"
RS.Open "select 日期 from 日期清單 order by 日期 desc", DB, 3, 3
temp = RS.getrows
With Sheets("工作表1")
.Select
.Shapes.Range(Array("List_0", "List_1", "Combo_0")).Delete
.Cells.Clear
Set list_0 = .ListBoxes.Add(.Range("a3").Left + 1, .Range("a3").Top, 82, 400)
Set list_1 = .ListBoxes.Add(.Range("b3").Left + 1, .Range("b3").Top, 82, 400)
Set Combo_0 = .Shapes.AddFormControl(xlDropDown, .Range("a1").Left, .Range("a1").Top, 86, 15)
With list_0
.Name = "list_0"
list_0.List = temp()
.Selected(2) = True
.OnAction = "Listbox_Change"
End With
With list_1
.Name = "list_1"
list_1.List = temp()
.Selected(1) = True
.OnAction = "Listbox_Change"
End With
With Combo_0
.Name = "Combo_0"
.ControlFormat.DropDownLines = 10
Sheets("常用股票").Range("a1") = "股票代號"
Call AddComboData(0, 1)
.OnAction = "Combo_0_Change"
End With
If Stockid = "" Then Stockid = .Shapes("combo_0").ControlFormat.List(1)
.Cells.Font.Size = "10"
.Columns.AutoFit
.Columns("A:B").ColumnWidth = 15
.Cells(1, 1).Select
End With
Application.ScreenUpdating = True
Debug.Print "表單物件" & Sheets("工作表1").Shapes.Count, "default stockid=" & Stockid
Erase temp
RS.Close
DB.Close
Set RS = Nothing
Set DB = Nothing
End Sub
Sub Listbox_Change()
Dim LastRow As Integer
LastRow = Sheets("常用股票").Range("a1").CurrentRegion.Rows.Count
If Stockid <> "股票代號" And LastRow > 1 Then
Use_Combo_Changeid = True
Call Manually
End If
End Sub
Sub Combo_0_Change()
Dim Combo_Select As Integer, LastRow As Integer
LastRow = Sheets("常用股票").Range("a1").CurrentRegion.Rows.Count
With Sheets("工作表1")
Combo_Select = .Shapes("combo_0").ControlFormat.Value
Stockid = .Shapes("combo_0").ControlFormat.List(Combo_Select)
Debug.Print Stockid
End With
If Stockid <> "股票代號" And LastRow > 1 Then
Use_Combo_Changeid = True
Call Manually
End If
End Sub
Sub AddComboData(LastRow As Integer, Combo_Select)
Dim Combo_Range As String
If LastRow = 0 Then
LastRow = Sheets("常用股票").Range("a1").CurrentRegion.Rows.Count
Combo_Range = "常用股票!$A$2:$A$" & LastRow
End If
If LastRow = 1 Then
Combo_Range = "常用股票!$A$1:$A$" & LastRow
End If
If LastRow > 1 Then
Combo_Range = "常用股票!$A$2:$A$" & LastRow
End If
With Sheets("工作表1")
.Shapes("combo_0").ControlFormat.ListFillRange = Combo_Range
.Shapes("combo_0").ControlFormat.Value = Combo_Select
End With
End Sub
Sub Update_TDCC_day()
'====for debug ======
'Target = ThisWorkbook.Path & "\" & "stock.accdb"
'====================
ttt = Timer
Dim GetXml As Object, DB As Object, RS As Object, r As Integer, TDCC_day() As String, a As Integer, d As Integer
Set GetXml = CreateObject("msxml2.xmlhttp")
Set DB = CreateObject("ADODB.Connection")
Set RS = CreateObject("ADODB.Recordset")
DB.Open "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & Target & ";"
r = 0
retry1:
On Error Resume Next
With GetXml
.Open "POST", "https://www.tdcc.com.tw/smWeb/QryStockAjax.do", False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.setRequestHeader "Referer", "https://www.tdcc.com.tw/smWeb/QryStock.jsp"
.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
.send "REQ_OPR=qrySelScaDates"
If InStr(.responsetext, "Your request timed out") > 0 Or .responsetext = "[]" Then
Debug.Print "get day timeout"
Delaytick (0.5)
r = r + 1
Debug.Print r
If r > 1 Then
MsgBox "線上日期無法更新，使用離線日期顯示，請稍後手動更新線上日期", vbOKOnly, "Error"
Sheets("工作表1").Buttons("TDCC_day").Visible = True
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
TDCC_day = Split(Replace(Replace(Replace(.responsetext, "[", ""), "]", ""), """", ""), ",")
For i = 0 To UBound(TDCC_day)
RS.Open "SELECT 日期 FROM 日期清單 WHERE 日期='" & TDCC_day(i) & "'", DB, 3, 3
If RS.RecordCount = 0 Then
'Debug.Print "新增日期", TDCC_day(i), RS.RecordCount
DB.Execute = "INSERT INTO 日期清單 (日期) VALUES ('" & TDCC_day(i) & "')"
a = a + 1
Else
'"日期重覆"
d = d + 1
End If
RS.Close
Next i
End With
DB.Close
Set RS = Nothing
Set DB = Nothing
Set GetXml = Nothing
Sheets("工作表1").Buttons("TDCC_day").Visible = False
Debug.Print "Update_TDCC_day", "新增" & a, "重覆" & d, Timer - ttt
End Sub
Sub Checkdb_GetPath()
Target = ThisWorkbook.Path & "\" & DBname
If Dir(Target) <> "" Then
Debug.Print "db ready"
Use_Combo_Changeid = True
Else
MsgBox "資料庫不存在，程式結束"
Application.DisplayAlerts = False
Application.Quit
ThisWorkbook.Close SaveChanges:=False
Application.DisplayAlerts = True
End If
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
Sub Auto_Open()
Application.ErrorCheckingOptions.BackgroundChecking = False
Application.ScreenUpdating = False
End Sub
'=========================================
集保戶股權分散表查詢，這次改版中，對連續查詢次數、時間，有了非常嚴格的限制
太快就會暫時檔一下ip，不確定是改版中的限制還是會變成常駐功能
為了避免程式出錯，修改如下
一、減少重試次數
二、大幅增加2次查詢時間間隔
三、因檔ip，出現多種error，改寫部份on error程式碼，增加reset on error
四、增加一個手動更新按鈕(線上日期無法更新時使用)
五、多增加一些除錯用訊息，可在即時運算視窗中檢視
此次更新，並不會讓下載“線上”資料時變快，只是讓擋ip時，程式不會出錯
如果平常就有在查資料，速度基本上不受影響
有點選過的資料會自動從資料庫取出
'==================================================================
純線上版程式碼就不更新了
(有興趣的可以參考資料庫版中，on error 的處理方式，自行改寫)
更新449樓資料庫版部份程式碼(資料庫不用重新下載)
如果有大量自訂股票清單，請先備份出來，清單沒有存在資料庫
(20190930 07:00 補充，經測試，目前網站還在改版中，資料有時不能下載是正常的，請耐心等待)
(20200421 因網頁改版，更新部份程式碼)
[點擊下載](需配合358樓離線資料庫，已有資料庫的不用重新下載)
內文搜尋
從 APP 打開
X