|
Sub 最新行情()
Dim winhttp, URL, i, j, t1, k, d, code, c, oDoc, n, r, y, m, f, arr1, h, jd, arr(1 To 40, 1 To 13), objJS, objS, tt, p, ar(), sht, node
Set winhttp = CreateObject("WinHttp.WinHttpRequest.5.1")
Set objJS = CreateObject("MSScriptControl.ScriptControl")
Set oDoc = CreateObject("htmlfile")
Application.ScreenUpdating = False
Application.DisplayStatusBar = True
arr1 = Array("代码", "名称", "最新", "昨收", "涨跌额", "涨跌幅")
Sheet1.UsedRange.Offset(1, 0).ClearContents
Sheet1.[a1].Resize(1, 8) = arr1
ar = Array("symbol", "name", "trade", "settlement", "pricechange", "changepercent")
With winhttp
For c = 1 To 5
On Error Resume Next
URL = "http://money.finance.sina.com.cn/quotes_service/api/json_v2.php/Market_Center.getHQNodeData?page=" & c & "&num=40&sort=symbol&asc=1&node=sz_a&symbol=&_s_r_a=init"
.Open "GET", URL, False
.setRequestHeader "Connection", "Keep-Alive"
.Send
t1 = BytesToBstr(.ResponseBody, "GB2312")
' With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
' .SetText t1
' .PutInClipboard
' End With
tt = "var mydata=" & t1
With objJS
.Language = "javascript"
.addcode tt
Set objS = .codeobject
For Each p In CallByName(objS, "mydata", VbGet)
n = n + 1
For j = 1 To 6
arr(n, j) = CallByName(p, ar(j - 1), VbGet)
Next
Next
End With
Range("a" & [a1048576].End(xlUp).Row + 1).Resize(40, 6) = arr
Erase arr
n = 0
Next c
End With
Sheet1.UsedRange.Columns.AutoFit
Sheet1.UsedRange.HorizontalAlignment = xlCenter
Set winhttp = Nothing
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
Function BytesToBstr(strBody, CodeBase) '使用Adodb.Stream对象提取字符串
Dim objStream
On Error Resume Next
Set objStream = CreateObject("Adodb.Stream")
With objStream
.Type = 1 '二进制
.Mode = 3 '读写
.Open
.Write strBody '二进制数组写入Adodb.Stream对象内部
.Position = 0 '位置起始为0
.Type = 2 '字符串
.Charset = CodeBase '数据的编码格式
BytesToBstr = .ReadText '得到字符串
End With
objStream.Close
Set objStream = Nothing
If Err.Number <> 0 Then BytesToBstr = ""
On Error GoTo 0
End Function
|
