個人積分：0分
文章編號：68555977
個人積分：2598分
文章編號：68559523
cji3cj6xu6 wrote:
看了網路的資料，發現我的IE安全性勾選的是 TLS 1.0, TLS 1.1， TLS 1.2
與該資料相符，於是將
With CreateObject("WinHttp.WinHttpRequest.5.1")
改為以下
With CreateObject("MSXML2.XmlHttp")
即可正常使用。
...(恕刪)
通常是proxy 、vpn 、電腦時間，的問題，ie設定不影響75樓的範例
除非您用 CreateObject("InternetExplorer.Application")，才會被影響
改成CreateObject("MSXML2.XmlHttp")可以用，是因為這個網站也可以這樣用
有些網站一定要用CreateObject("WinHttp.WinHttpRequest.5.1")，才能抓資料
我認為您是系統問題比較大
您可以試試以下2種方法(先試1，不行試看看2)，在.send之前多加一行程式碼
一、取消WinHttp.WinHttpRequest.5.1的錯誤檢查
.Option(4) = 13056
二、取消WinHttp.WinHttpRequest.5.1 ssl檢查
.Option(2) = 950
.Option(4) = &H3300
個人積分：0分
文章編號：68559610
個人積分：0分
文章編號：68564486
個人積分：2598分
文章編號：68874670
因為很簡單，不多做說明了
'===========================================
Sub Get_oil()
Dim Xmlhttp As Object, Clipboard As Object
Set Clipboard = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
ttt = Timer
Set Xmlhttp = CreateObject("Microsoft.XMLHTTP")
With Xmlhttp
.Open "GET", "http://www3.cpc.com.tw/opendata_d00/webservice/中油主要產品牌價.csv", False
.send
End With
With Clipboard
.SetText Xmlhttp.responsetext
.PutInClipboard
End With
With Sheets("工作表1")
.Select
.Cells.Clear
.Cells(1, 1).Select
.PasteSpecial NoHTMLFormatting:=True
.Columns(1).TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, Comma:=True, TrailingMinusNumbers:=True
.Columns.AutoFit
.Cells(1, 1).Select
End With
MsgBox "下載時間" & Round(Timer - ttt, 2) & "秒", vbOKOnly, "Report"
Set Xmlhttp = Nothing
Set Clipboard = Nothing
End Sub
'===========================================
附加壓縮檔: 201806/mobile01-00a7fe6ce1159182213078efcc2a50c1.zip
個人積分：1分
文章編號：68937754
個人積分：2分
文章編號：68962554
Cells.Clear
Dim URL, HTMLsourcecode, GetXml
Set HTMLsourcecode = CreateObject("htmlfile")
Set GetXml = CreateObject("msxml2.xmlhttp")
URL = "https://fubon-ebrokerdj.fbs.com.tw/z/zc/zcj/zcj_1413.djhtm"
With GetXml
.Open "GET", URL, False
.setRequestHeader "Cache-Control", "no-cache"
.setRequestHeader "Pragma", "no-cache"
.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
.send
HTMLsourcecode.body.innerhtml = .responsetext
Debug.Print HTMLsourcecode.body.innerhtml
Set Table = HTMLsourcecode.all.tags("table")(1).Rows
MsgBox Table.Length
MsgBox Table(0).Cells.Length
For i = 0 To Table.Length - 1
For j = 0 To Table(i).Cells.Length - 1
ActiveSheet.Cells(i + 1, j + 1) = Table(i).Cells(j).innertext
Next j
Next i
End With
Set HTMLsourcecode = Nothing
Set GetXml = Nothing
End Sub
我用21樓的方法 抓籌碼流向 結果表格集中在一起 不知哪裡錯了 煩請版主指教 謝謝!
個人積分：2598分
文章編號：68962830
個人積分：2分
文章編號：68973804
個人積分：2598分
文章編號：68985339
https://djinfo.cathaysec.com.tw/z/ze/zef/zef.djhtm
這個網站有點特別，很單純的表格，用21樓的簡短程式碼就可以下載
雖然資料有完整下載，可是第98格之後，股票名稱會不見(如下圖)
其實這是因為名稱是超連結，而98格之後的名稱，用了2個網頁語法的關係
造成程式無法正常抓出名稱，只抓到空白字串
解決方式其實不難，這種超連結造成的問題，只需改抓innerhtml
再另外用簡單的文字處理函數，拆分就可以了
程式碼只需增加 if ... end if ，基本寫法不變，不用另外學比較複雜的程式碼
'================================================
Sub djinfo()
Cells.Clear
Dim URL As String, temp As String, HTML As Object, GetXml As Object
Set HTML = CreateObject("htmlfile")
Set GetXml = CreateObject("msxml2.xmlhttp")
URL = "https://djinfo.cathaysec.com.tw/z/ze/zef/zef.djhtm"
With GetXml
.Open "GET", URL, False
.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
HTML.body.innerhtml = convertraw(.responsebody)
Set Table = HTML.all.tags("table")(2).Rows
For i = 0 To Table.Length - 1
For j = 0 To Table(i).Cells.Length - 1
If j = 0 And i > 1 Then
'有興趣的這裡可以先不要拆分字串， 先用Table(i).Cells(j).innerhtml，看看有什麼不同
temp = Replace(Split(Table(i).Cells(j).innerhtml, ">")(1), "</A", "")
If InStr(temp, "GenLink2stk") > 0 Then temp = Replace(Split(Split(temp, "AS")(1), "')")(0), "','", "")
Else
temp = Table(i).Cells(j).innertext
End If
Sheets("工作表1").Cells(i + 1, j + 1) = temp
Next j
Next i
End With
With Sheets("工作表1")
.Select
.Columns.AutoFit
.Cells(1, 1).Select
End With
Set HTML = Nothing
Set GetXml = Nothing
End Sub
Function convertraw(rawdata)
Dim rawstr
Set rawstr = CreateObject("adodb.stream")
With rawstr
.Type = 1
.Mode = 3
.Open
.Write rawdata
.Position = 0
.Type = 2
.Charset = "big5"
convertraw = .ReadText
.Close
End With
Set rawstr = Nothing
End Function
'================================================
附加壓縮檔: 201806/mobile01-de6018480428ae06924531e5f250d7ad.zip
關閉廣告