個人積分：1分
文章編號：67640262
小弟下載
附加壓縮檔: 201802/mobile01-e374c952285b259a13af00208f2da971.zip
時被卡巴斯基擋下來了
資訊如下
Access denied
The requested URL cannot be provided
Object URL:
http://attach.mobile01.com/attachdownload/201802/mobile01-e374c952285b259a13af00208f2da971.zip
Reason: the object is infected by HEUR:Trojan.Script.Agent.gen
Message generated on: 2018/3/5 下午 10:41:24
其他附加檔案都不會有此現象
不知是何原因
請大大幫忙看看了
個人積分：2598分
文章編號：67640436
feib0218 wrote:
附加壓縮檔: 201802/mobile01-e374c952285b259a13af00208f2da971.zip
時被卡巴斯基擋下來了...(恕刪)
我重新下載檢查了，確定檔案沒問題，這是我上傳的檔案沒錯
可能是部份程式碼被誤判了成Script病毒了
剛剛再重新用卡巴掃毒(我的原始檔案+mobile01 下載的檔案)
顯示是病毒
然後隨便刪掉幾刪程式碼，重新掃毒
增加一些沒用的字串，改幾行字，檔案特徵改變，再掃毒，就變成安全檔案了
所以只是卡巴誤判
如果您還是不放心的話，請直接複製文中的程式碼，自己做一個新檔案
程式碼和上傳的檔案中的是一模一樣的
我po文程式碼一向是公開透明的，檔案、文章，都各有一份
沒有特別加上什麼不能見人的東西
，請您放心偶爾不小心沒處理好的bug，請無視，那是因為我寫範例
擔心的，請copy內文程式碼，自己建檔，相信我的，請直接下載
個人積分：1分
文章編號：67652324
個人積分：0分
文章編號：67699938
個人積分：5分
文章編號：67858849
snare大你好
請問一下，昨天要下載集保戶股權分散表查詢資料，不曉得集保戶股權分散表查詢是否網頁有改版，無法下載資料，如何找到新的網址格式，我是用web的方式下載，如下部分下載程式。
原始下載網址：
http://www.tdcc.com.tw/smWeb/QryStock.jsp?SCA_DATE=20180323&SqlMethod=StockNo&StockNo=2344&StockName=&sub=%ACd%B8%DF
''''''''''''''''''''''''''''''''''程式碼如下'''''''''''''''''''''''''''''''''''''''''''''''''''''
For DateVar = 0 To UBound(Br)
tr = 1 + (DateVar * 27)
Qur = "http://www.tdcc.com.tw/smWeb/QryStock.jsp?SCA_DATE=" & Br(DateVar) & "&SqlMethod=StockNo&StockNo=" & stkno & "&StockName=&sub=%ACd%B8%DF"
.QueryTables.Add "URL;" & Qur, .Cells(tr, "A")
With .QueryTables(1)
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "6,7,8"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
.Delete
End With
Next
個人積分：63分
文章編號：67860363
個人積分：2598分
文章編號：67864614
peter624 wrote:
無法下載資料，如何找到新的網址格式，我是用web的方式下載，如下部分下載程式。
原始下載網址：
http://www.tdcc.com.tw/smWeb/QryStock.jsp?SCA_DATE=20180323&SqlMethod=StockNo&StockNo=2344&StockName=&sub=%ACd%B8%DF...(恕刪)
因為網址變了，而且改成 ajax ，所以您無法下載
http://www.tdcc.com.tw/smWeb/QryStockAjax.do
web query 我不用，所以就不寫webquery範例，我只用xml方式
建議您改參考我的xml範例
個人積分：2598分
文章編號：67864644
因集保戶股權分散表查詢，網址改變，298樓範例失效無法下載
請改用這樓的新版程式碼
'=====================================
'工作表1要建立一個表單控製項的按鈕
'程式碼放在 thisworkbook
'=====================================
Private Sub Workbook_Open()
Call AddDateListBox
End Sub
'=====================================
'以下程式碼放在模組
'=====================================
Sub acer()
Dim HTMLsourcecode As Object, GetXml As Object, day(1 To 2) As String, stockid As String, stockname As String, r As Integer, url_a As String
Set HTMLsourcecode = CreateObject("htmlfile")
Set GetXml = CreateObject("WinHttp.WinHttpRequest.5.1")
On Error GoTo redownload
Sheets("工作表1").Columns("C:N").ClearContents
If Sheets("工作表1").Cells(1, 1) = "" Then
stockid = InputBox("請輸入證券代號" & vbNewLine & "(輸入後，也可以直接修改a1儲存格)", , "2353")
If stockid = "" Then Exit Sub
Sheets("工作表1").Cells(1, 1).NumberFormatLocal = "@"
Sheets("工作表1").Cells(1, 1) = stockid
Else
stockid = Sheets("工作表1").Cells(1, 1)
End If
Application.ScreenUpdating = False
ttt = Timer
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"))
If Sheets("工作表1").ListBoxes("list_0") = 0 Then
For d = 1 To 10
Debug.Print "retry listbox"
Call AddDateListBox
If Sheets("工作表1").ListBoxes("list_0") <> 0 Then Exit For
Next d
End If
If Sheets("工作表1").ListBoxes("list_0") = 0 Then
MsgBox "請稍後再試", vbOKOnly, "Error"
Exit Sub
End If
For k = 1 To 2
r = 0
retry2:
url_a = "scaDates=" & day(k) & "&scaDate=" & day(k) & "&SqlMethod=StockNo&StockNo=" & stockid & "&radioStockNo=" & 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 (0.01)
r = r + 1
If r > 10 Then
MsgBox "請稍後再試", vbOKOnly, "Error"
Exit Sub
End If
GoTo retry2
End If
'20180828 更新，網頁表格換位置了，(7、8)，改成(6、7)
stockname = HTMLsourcecode.all.tags("table")(6).Rows(0).innertext
Set Table = HTMLsourcecode.all.tags("table")(7).Rows
If Table(1).Cells(0).innertext = "無此資料" Then
Debug.Print Table(1).Cells(0).innertext
Delaytick (0.01)
r = r + 1
If r > 10 Then
Sheets("工作表1").Columns("C:N").ClearContents
MsgBox "資料回傳異常 or 股票代號錯誤", vbOKOnly, "Error"
Exit Sub
End If
GoTo retry2
End If
With Sheets("工作表1")
For i = 1 To Table.Length - 1
For j = 0 To Table(i).Cells.Length - 1
.Cells(i + 3, j + 3 + ((k - 1) * 5)) = Table(i).Cells(j).innertext
Next j
Next i
End With
End With
Next k
With Sheets("工作表1")
.Range("c3:n3") = Array("序", "持股", "人數", "股數", "比例%", "序", "持股", "人數", "股數", "比例%", "人數變化", "張數變化")
.Cells(2, 4) = day(1)
.Cells(2, 9) = day(2)
.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
'不想加上顏色的，禁用下面這一行
Call SetFormatCondition
.Cells.Font.Size = "10"
.Columns.AutoFit
.Columns("A:B").ColumnWidth = 15
.Cells(1, 4) = Split(stockname, "資料日期")(0) ' debug
.Cells(1, 1).Select
End With
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"
If r > 10 Then
Sheets("工作表1").Columns("C:N").ClearContents
MsgBox "連線異常，請稍後再試", vbOKOnly, "Error"
Exit Sub
End If
GoTo retry2
End Sub
Sub AddDateListBox()
Dim SCA_DATE, GetXml As Object, list_0, list_1, temp(), r As Integer
Set GetXml = CreateObject("WinHttp.WinHttpRequest.5.1")
On Error Resume Next
r = 0
retry1:
With GetXml
'20180818 修正網址
.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 "timeout"
Delaytick (0.01)
r = r + 1
If r > 10 Then
MsgBox "請稍後再試", vbOKOnly, "Error"
Exit Sub
End If
GoTo retry1
End If
SCA_DATE = Split(Replace(Replace(.responsetext, "[", ""), "]", ""), ",")
ReDim temp(UBound(SCA_DATE))
For i = 0 To UBound(SCA_DATE)
temp(i) = Replace(SCA_DATE(i), """", "")
Next i
End With
With Sheets("工作表1")
.ListBoxes("list_0").Delete
.ListBoxes("list_1").Delete
.Cells.Clear
.Cells(1, 1).NumberFormatLocal = "@"
Set list_0 = .ListBoxes.Add(.Range("a3").Left, .Range("a3").Top, 70, 400)
Set list_1 = .ListBoxes.Add(.Range("b3").Left, .Range("b3").Top, 70, 400)
With list_0
.Name = "list_0"
list_0.List = temp()
.Selected(2) = True
End With
With list_1
.Name = "list_1"
list_1.List = temp()
.Selected(1) = True
End With
.Cells.Font.Size = "10"
.Columns.AutoFit
.Cells(1, 1).Select
End With
Erase temp()
Set GetXml = Nothing
End Sub
'(20180402更新錯誤的delaytick副程式)
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
'(20180402順便加上格式化條件上色)
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
'=====================================
(2018-03-25 22:20 更新)
因為網站改版關係，連線異常、超級不穩定，資料時有時無
(就算使用人工查詢，也一樣的情形)
(測試21次)
正常情況下，2天份資料約0.3秒，每筆約0.15秒
不正常時可能會多到4秒
所以，增加部份程式碼，並把重試次數，增加到10次
另外增加除錯功能，出錯時不會中斷程式
下載失敗時，程式會自動中止，再重按一次下載即可
可避免要一直重開excel檔的問題
程式重跑時，資料下載失敗、連線錯誤、timeout…等等，會在即時運算試窗中，以簡單的訊息提示
有興趣可以打開來看
(2018-03-27 更新，測試21次)
今天網站正常多了
(當網頁恢復正常時，此程式不需修改，可繼續使用，那些判斷、中斷、重試…等等，不影響速度)
(2018-03-27 因網站編碼恢復正常，取消使用轉碼convertraw()副程式)
(2018-03-28 我忘了有0開頭的股票
，用inputbox 輸入的沒問題，用a1輸入的會少0)(下載過的不用重新下載，只差2行程式碼，自己補上就好))
(2018-04-02 更新錯誤的delaytick副程式，順便加上格式化條件上色)
(2018-04-06 今天才發現，檔案中不小心多放了一個空白的listbox)
(只要打開設計模式，把listbox刪光，存檔後重開即可，不需重新下載檔案，不理它也可以)
(2018-04-14 網頁改版，表格換位置了，更新程式碼)
(2018-08-18 網頁改版，修正網址)
(2018-08-28 網頁改版，表格換位置了，更新程式碼)
附加壓縮檔: 201808/mobile01-8b228b426b6e461af3bd7b645c1d0e9e.zip
個人積分：5分
文章編號：67865775
個人積分：778分
文章編號：67867920
關閉廣告