個人積分：0分
文章編號：73078310
個人積分：2602分
文章編號：73090494
ckgenie wrote:
我使用雅虎是正常的(query1.finance.yahoo.com/v7/finance/download/)
請問版主所使用的作業系統是?是否因為我是XP無法使用,XP系統我有使用樓主修正方式已經可使用(WinHttp.WinHttpRequest.5.1)
請問版主可有解決XP運行方法?...(恕刪)
是的，就是xp系統的問題，sgx這個網站用的https版本更新，xp不支援
ie8打不開sgx的網頁，所以無法下載
(xp pos修正後，finance.yahoo 在ie8、firefox for xp都可正常開啟，所以可以下載)
補充：使用 https://www.ssllabs.com/ssltest/analyze.html 分析網站
www2.sgx.com
finance.yahoo.com
firfox chrome 在xp中還有2個版本可以開 sgx 的網頁
看來是tls + sha 的問題，用純vba暫時無簡單的方式可解決
除非微軟願意出新版的xp pos修正
個人積分：4分
文章編號：73319831
請教版主,該如何修改程式,當遇到網站LAG延遲時,不會讓滑鼠游標一直轉圈圈,而跳到下一個動作或exit sub,謝謝!
Urls = "http://......txt"
Set Retrievals = CreateObject("Microsoft.XMLHTTP")
With Retrievals
.Open "Get", Urls, False, "", ""
.setRequestHeader "Content-Type", "text/xml;charset=utf-8"
.setRequestHeader "If-Modified-Since", "0"
.setRequestHeader "Cache-Control", "no-cache"
.Send
If .ReadyState <> 4 Then Exit Sub
DownLoadHtm = StrConv(.ResponseBody, vbUnicode)
End With
下一個動作....
個人積分：2602分
文章編號：73320706
jason2443 wrote:
有時遇到網站LAG延遲時,滑鼠游標會一直轉圈圈,直到網站正常時,轉圈圈才停止...(恕刪)
因為
.Open "GET or POST", URL, false
send 之後會等資料抓完、網站超時(掛掉)，才會跳下一行
可參考175樓
使用 .WaitForResponse 限制等待時間
如果該網站不能用WinHttp.WinHttpRequest.5.1
可改用
.Open "GET or POST", URL, true
.send
'====================
'因為true不會等資料下載，所以這裡需加入設定等待時間的程式碼
'例如348樓Delaytick()副程式
'或其它您喜歡用的方式
'====================
'這裡加入檢查、除錯用的程式碼，確定.responsetext是否有資料
'沒有就exit sub 或重試
'====================
'以下才是整理資料的主程式
個人積分：2分
文章編號：73705088
不知原因？
Sub TSE_close()
'上櫃otc股價指數, 上市tse股價指數
Application.ScreenUpdating = False
theday = Sheets("SH2").Range("M4")
' sDate_tmp = Replace(theday, "/", "")
sheetsname = "twse"
Sheets(sheetsname).Select
Sheets(sheetsname).Cells.Clear
Dim i As Integer, temp, Jsondata As Object, DecodeJson
Dim TempArray()
Set Jsondata = CreateObject("HtmlFile")
Jsondata.write ""
With CreateObject("WinHttp.WinHttpRequest.5.1")
URL = "https://www.twse.com.tw/exchangeReport/MI_INDEX?response=json&date=" & theday & "&type=MS&_="
.Open "GET", "https://www.twse.com.tw/zh/page/trading/exchange/MI_INDEX.html", False
.Send
.Open "GET", URL, False
.setRequestHeader "Referer", "https://www.twse.com.tw/zh/page/trading/exchange/MI_INDEX.html"
.setRequestHeader "Cache-Control", "no-cache"
.setRequestHeader "Pragma", "no-cache"
.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
.Send
If Len(.Responsetext) = 16 Then
Sheets(sheetsname).Cells.Clear
Sheets(sheetsname).Cells(1, 1) = "網路忙線中，" & 30 + Int(Rnd(Timer) * 15 + 1) & "秒後，自動重新下載"
Application.OnTime Now + TimeSerial(0, 0, 30 + Int(Rnd(Timer) * 15 + 1)), "tse_otc"
Exit Sub
End If
Set DecodeJson = Jsondata.JsonParse(.Responsetext)
If DecodeJson.stat = "很抱歉，沒有符合條件的資料!" Then
Exit Sub
End If
Sheets(sheetsname).Range("A1") = DecodeJson.subtitle1
For k = 1 To 4
thefields = "fields" & k
Set tempfield = CallByName(DecodeJson, thefields, VbGet)
thedata = "data" & k
Set temp1 = CallByName(DecodeJson, thedata, VbGet)
lb1 = CallByName(temp1, "length", VbGet)
UB1 = CallByName(CallByName(temp1, 0, VbGet), "length", VbGet)
ReDim TempArray(lb1 - 1, UB1 - 1)
For i = 0 To CallByName(temp1, "length", VbGet) - 1
Set temp2 = CallByName(temp1, i, VbGet)
For x = 0 To CallByName(temp2, "length", VbGet) - 1
If (x = 2 And k = 1) Or (x = 2 And k = 2) Then
TempArray(i, x) = Mid(CallByName(temp2, x, VbGet), 23, 1)
Else
TempArray(i, x) = CallByName(temp2, x, VbGet)
End If
Next x
Next i
thelastrow = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
' If thelastrow = 1 Then
' thelastrow = 0
' End If
Sheets(sheetsname).Range(Sheets(sheetsname).Cells(thelastrow + 1, 1), Sheets(sheetsname).Cells(thelastrow + 1, UBound(Split(tempfield, ",")) - LBound(Split(tempfield, ",")) + 1)).Interior.ColorIndex = 24
Sheets(sheetsname).Range(Sheets(sheetsname).Cells(thelastrow + 1, 1), Sheets(sheetsname).Cells(thelastrow + 1, UBound(Split(tempfield, ",")) - LBound(Split(tempfield, ",")) + 1)) = Split(tempfield, ",")
Sheets(sheetsname).Range(Sheets(sheetsname).Cells(thelastrow + 1 + 1, 1), Sheets(sheetsname).Cells(thelastrow + 1 + i, UB1)) = TempArray
Next k
End With
Erase TempArray
Sheets(sheetsname).Columns.AutoFit
Sheets(sheetsname).Range("b:b,d:d,e:e,f:f").HorizontalAlignment = xlRight
Sheets(sheetsname).Cells(1, 1).Select
Set DecodeJson = Nothing
Set Jsondata = Nothing
Set temp1 = Nothing
Set temp2 = Nothing
Erase TempArray
Application.ScreenUpdating = True
Sheets("sh2").Select
End Sub
個人積分：2602分
文章編號：73705983
yuhuahsiao wrote:
原本下方程式可執行，但突然不行了.
不知原因？
...(恕刪)
要改成這樣
(點下可看大圖)
因為json格式不好處理，且網站有提供csv 、html方式下載
如果不是只取其中幾筆資料
一、可改用html+剪貼薄處理，除錯方式可參考(223樓+其它很多樓)
(點下可看大圖)
二、可改用csv處理(send程式碼同一)
Url = "https://www.twse.com.tw/exchangeReport/MI_INDEX?response=csv&date=20190625&type=MS"
取檔名、下載、開啟、存檔方式，請參考269樓、271樓、272樓+其它很多樓
(雖然路徑不可以有雙引號是基本常識，但還是提醒一下：檔名如果有=>"雙引號，ADODB.Stream會出錯無法存檔)
(點下可看大圖)
date、type 請自行修改
"MS"=大盤統計資訊
"MS2"=委託及成交統計資訊
"ALL"=全部
"ALLBUT0999"=全部(不含權證、牛熊證、可展延牛熊證)
"0049"=封閉式基金
"0099P"=ETF
"029999"=ETN
"019919T"=受益證券
"0999"=認購權證(不含牛證)
"0999P"=認售權證(不含熊證)
"0999C"=牛證(不含可展延牛證)
"0999B"=熊證(不含可展延熊證)
"0999X"=可展延牛證
"0999Y"=可展延熊證
"0999GA"=附認股權特別股
"0999GD"=附認股權公司債
"0999G9"=認股權憑證
"CB"=可轉換公司債
"01"=水泥工業
"02"=食品工業
"03"=塑膠工業
"04"=紡織纖維
"05"=電機機械
"06"=電器電纜
"07"=化學生技醫療
"21"=化學工業
"22"=生技醫療業
"08"=玻璃陶瓷
"09"=造紙工業
"10"=鋼鐵工業
"11"=橡膠工業
"12"=汽車工業
"13"=電子工業
"24"=半導體業
"25"=電腦及週邊設備業
"26"=光電業
"27"=通信網路業
"28"=電子零組件業
"29"=電子通路業
"30"=資訊服務業
"31"=其他電子業
"14"=建材營造
"15"=航運業
"16"=觀光事業
"17"=金融保險
"18"=貿易百貨
"9299"=存託憑證
"23"=油電燃氣業
"19"=綜合
"20"=其他
個人積分：2分
文章編號：73750716
個人積分：2602分
文章編號：73750878
個人積分：0分
文章編號：74024315
這是別人寫的VBA..但不知為何突然7/1後就無法使用了
..一直出現.."執行階段錯誤 -2147024891 (80070005)存取被拒"(如圖一所示)...進去程式碼檢查....偵錯一直停留在"XML.send thePOSTdata"有標黃色的這一行(如圖2所示)..不知什麼問題突然造成檔案無法使用~~後來我查了一些資料...將程式碼的
Set XML = CreateObject("Microsoft.XMLHTTP")修改成
Set XML = CreateObject("Msxml2.ServerXMLHTTP")之後
不再出現"執行階段錯誤 -2147024891 (80070005)存取被拒"的錯誤訊息
但要查當天資料卻出現"不計算結算商品"(如圖4)...
也無法下載歷史資料查詢
(如圖:例如我在讀取資料輸入"2019/06/06"要查歷史資料,下方的商品選擇裡的上商品名..卻還是出現當天7月份的資料...卻不是出現我要查詢的6月份的歷史資料(如圖3)..我到選擇權每日交易行情的頁面看...下載到EXCEL的資料
依舊是當天的資料
請問是什麼問題??謝謝版主
原始程式碼如下:
Option Explicit
Dim OP1_N As String
Dim OP1Strike_L As String
Dim OP1Strike_H As String
Dim OP2_N As String
Dim OP2Strike_L As String
Dim OP2Strike_H As String
Dim OP3_N As String
Dim OP3Strike_L As String
Dim OP3Strike_H As String
Function 選擇權每日交易行情(ByVal QueryDate As String) As Boolean
Dim SheetName As String
SheetName = "選擇權每日交易行情"
Dim OPsheet As Worksheet
Set OPsheet = ThisWorkbook.Sheets(SheetName)
Dim sYear, smonth, sDay As String
Dim ByteToText As String
Dim HTML_Content As Object
Dim Stream As Object
Dim XML As Object
Dim hTable As Object
'QueryDate = "2017/8/8" 'for tset
OPsheet.Range("A1:Z150").Clear
Set HTML_Content = CreateObject("htmlfile")
Dim thePOSTdata, url
Set Stream = CreateObject("ADODB.stream")
Set XML = CreateObject("Microsoft.XMLHTTP")
sYear = Year(QueryDate)
smonth = VBA.Format(Month(QueryDate), "00")
sDay = VBA.Format(Day(QueryDate), "00")
'eyear = syear
'emonth = smonth
'eday = sday
url = "http://www.taifex.com.tw/cht/3/optDailyMarketReport"
'goday=&DATA_DATE_Y=2016&DATA_DATE_M=12&DATA_DATE_D=21&syear=2016&smonth=12&sday=21&datestart=2016%2F12%2F21&COMMODITY_ID=TXO
'thePOSTdata = "goday=&DATA_DATE_Y=2016&DATA_DATE_M=12&DATA_DATE_D=21&syear=2016&smonth=12&sday=21&datestart=2016%2F12%2F21&COMMODITY_ID=TXO"
thePOSTdata = "queryType=2&marketCode=0&dateaddcnt=&commodity_id=TXO&commodity_id2=&queryDate=" & sYear & "/" & smonth & "/" & sDay & "&MarketCode=0&commodity_idt=TXO&commodity_id2t=&commodity_id2t2="
XML.Open "GET", url, 0
XML.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
XML.send thePOSTdata
With Stream
.Type = 1
.Mode = 3
.Open
.Write XML.responseBody
.Position = 0
.Type = 2
.Charset = "utf-8"
ByteToText = .ReadText
'MsgBox ByteToText
.Close
End With
If InStr(1, ByteToText, "查無資料") <> 0 Then '=0 為當天查無資料
'StockHistory = 99 '99 沒有資料
MsgBox "日期錯誤或當日沒開盤"
選擇權每日交易行情 = False
Exit Function '這裡返回的錯誤碼
End If
Dim xRow, xCol As Integer
Dim StartROW, StartCol As Integer
Dim x 'for test
HTML_Content.Body.Innerhtml = ByteToText '將文字轉移到Html的格式
Debug.Print ByteToText
'Set hTable = HTML_Content.getElementsByTagName("table") 'for test
'x = hTable.Length 'for test
StartCol = 1
StartROW = 1
Set hTable = HTML_Content.getElementsByTagName("table")(4) '指向 Table 4
For xRow = 0 To hTable.Rows.Length - 1
For xCol = 0 To hTable.Rows(xRow).Cells.Length - 1
OPsheet.Cells(StartROW, StartCol) = hTable.Rows(xRow).Cells(xCol).innertext
StartCol = StartCol + 1
Next
StartCol = 1
StartROW = StartROW + 1
Next
選擇權每日交易行情 = True
End Function
個人積分：2602分
文章編號：74024654
關閉廣告