网页取行情数据-2

方案3

门户网站获取行情

Sina股票数据接口 （股票见网上http://www.cnblogs.com/luluping/archive/2010/11/15/1877817.html）

期指内容：

分析网页 http://finance.sina.com.cn/futures/quotes/IC1605.shtml
获取接口 hq.sinajs.cn/?&list=CFF_RE_IC1605

var hq_str_CFF_RE_IC1605="5830.00,5837.00,5633.20,5652.80,15386,17623900000,22198,5652.80,,6525.80,5339.40,,,5887.80,5932.60,23189,0,0,--,--,--,--,--,--,--,--,0,0,--,--,--,--,--,--,--,--,2016-05-09,15:00:15,0,1,6156.400,5798.000,6156.400,5686.600,6248.400,5686.600,6248.400,5550.000,151.093";

可以看到行情时间，延迟15分钟 ……

分析字段，依次为： 今开，最高，最低，现价，总量，总额，持仓，收盘，结算，涨停，跌停，（-），（-），昨收，昨结，昨持仓，0,0

可惜结算价的更新太慢了……，且没有按照日期获取数据。

方案4

去中金所(www.cffex.com.cn)、上期所(www.shfe.com.cn)，大商所(www.dce.com.cn) 和 郑商所(www.czce.com.cn)

抓取：

其中中金所的数据是xml格式的 http://www.cffex.com.cn/fzjy/mrhq/201604/26/index.xml
上期所的数据是json格式的 http://www.shfe.com.cn/data/dailydata/kx/kx20160426.dat
大商与郑商是 表格http://www.dce.com.cn/PublicWeb/MainServlet?action=Pu00011_result&Pu00011_Input.trade_type=0&Pu00011_Input.trade_date=20160425&Pu00011_Input.variety=all
http://www.czce.com.cn/portal/DFSStaticFiles/Future/2016/20160425/FutureDataDaily.htm
部分vba代码如下：

On Error GoTo xmlerr
Dim xmldom As Object, node As Object, nod As Object
Set xmldom = CreateObject("Microsoft.XMLDOM")
' xmldom.setProperty "SelectionLanaguage", "XPath"     'xpath才支持contains, startwith等函数
' 增加xpath的支持，且必须在load完后，否则直接异常，vba内无异常捕获
xmldom.async = False
xmldom.Load url
xmldom.setProperty "SelectionLanguage", "XPath"
Set node = xmldom.SelectSingleNode("dailydatas//dailydata[contains(instrumentid,'" & iid & "')]")

If node Is Nothing Then
xmlWeb = Array(CVErr(xlErrNull), CVErr(xlErrNull), CVErr(xlErrNull))
Exit Function
End If

'Set xmlnodes = xmldom.getElementsByTagName("dailydata")
'Set Nodes = xmldom.SelectNodes("//dailydata")
For Each nod In node.ChildNodes
If nod.nodename = "settlementprice" Then
sprice = nod.Text
'ElseIf nod.nodename = "openprice" Then
'   oprice = nod.Text
ElseIf nod.nodename = "presettlementprice" Then
lsprice = nod.Text
ElseIf nod.nodename = "closeprice" Then
cprice = nod.Text
End If
Next
xmlWeb = Array(cprice, sprice, lsprice)

网上找的一个json类解析模块 （内部使用dictionary 解析json字符串） 见后面

json解析

Private Function jsonWeb(url As String, iid As String) As Variant()

Dim lsprice As Currency
Dim cprice As Currency
Dim sprice As Currency

Dim p As Object, js As String
Dim o   'Dictionary
Dim ics()
Dim ic  'Dictionary

On Error GoTo jsonerr:
Call getWeb(url, js)
If js = "" Then Exit Function

Set p = New vbsJson
Set o = p.Decode(js)
'Set c = o.Item("o_curinstrument")
ics = o.Item("o_curinstrument")
For Each ic In ics
If Left(ic.Item("PRODUCTID"), Len(iid) - 2) = LCase(Left(iid, Len(iid) - 4)) & "_f" And ic.Item("DELIVERYMONTH") = Right(iid, 4) Then
lsprice = ic.Item("PRESETTLEMENTPRICE")
cprice = ic.Item("CLOSEPRICE")
sprice = ic.Item("SETTLEMENTPRICE")
End If
Next
jsonWeb = Array(cprice, sprice, lsprice)

子函数，获取网页数据

Public Sub getWeb(url As String, ByRef response As String)
On Error GoTo ehl
' With ActiveSheet.QueryTables.add( _
'   Connection := "Text;"
Dim httpreq As Object
Set httpreq = CreateObject("MSXML2.XMLHTTP")
httpreq.Open "GET", url, False
'.setRequestHeader "Content-Type", "text/html;charset=UTF-8"   ' "application/x-www-form-urlencoded; charset=UTF-8"
'.setRequestHeader "Accept", "text/html,application/xhtml+xml,application/xml;q=0.9,image/webp,*/*;q=0.8"
'.setRequestHeader "Content-Type", "application/x-www-form-urlencoded; charset=UTF-8"
' .setRequestHeader "Accept-Language", "zh-CN,zh;q=0.8"
'.setRequestHeader "charset", "gbk"
httpreq.send
While httpreq.ReadyState <> 4
DoEvents
Wend

response = httpreq.responseText  'strText 'U8SToUnicode(StrConv(strText, vbUnicode))
Set httpreq = Nothing
Exit Sub
ehl:
MsgBox Err.Description
End Sub

结论：3大期货交易所的数据还算及时，但是中金所更新太慢了。

附上vbsjson类模块

'Class vbsJson
'Author: Demon
'Date: 2012/5/3
'Website: http://demon.tw Private Whitespace, NumberRegex, StringChunk
Private b, f, r, n, t

Private Sub Class_Initialize()
Whitespace = " " & vbTab & vbCr & vbLf
b = ChrW(8)
f = vbFormFeed
r = vbCr
n = vbLf
t = vbTab

Set NumberRegex = CreateObject("VBScript.RegExp")
NumberRegex.Pattern = "(-?(?:0|[1-9]\d*))(\.\d+)?([eE][-+]?\d+)?"
NumberRegex.Global = False
NumberRegex.MultiLine = True
NumberRegex.IgnoreCase = True

Set StringChunk = CreateObject("VBScript.RegExp") 'New RegExp
StringChunk.Pattern = "([\s\S]*?)([""\\\x00-\x1f])"
StringChunk.Global = False
StringChunk.MultiLine = True
StringChunk.IgnoreCase = True
End Sub

'Return a JSON string representation of a VBScript data structure
'Supports the following objects and types
'+-------------------+---------------+
'| VBScript          | JSON          |
'+===================+===============+
'| Dictionary        | object        |
'+-------------------+---------------+
'| Array             | array         |
'+-------------------+---------------+
'| String            | string        |
'+-------------------+---------------+
'| Number            | number        |
'+-------------------+---------------+
'| True              | true          |
'+-------------------+---------------+
'| False             | false         |
'+-------------------+---------------+
'| Null              | null          |
'+-------------------+---------------+
Public Function Encode(ByRef obj)
Dim buf, i, c, g
Set buf = CreateObject("Scripting.Dictionary")
Select Case VarType(obj)
Case vbNull
buf.Add buf.Count, "null"
Case vbBoolean
If obj Then
buf.Add buf.Count, "true"
Else
buf.Add buf.Count, "false"
End If
Case vbInteger, vbLong, vbSingle, vbDouble
buf.Add buf.Count, obj
Case vbString
buf.Add buf.Count, """"
For i = 1 To Len(obj)
c = mid(obj, i, 1)
Select Case c
Case """"
buf.Add buf.Count, "\"""
Case "\"
buf.Add buf.Count, "\\"
Case "/"
buf.Add buf.Count, "/"
Case b
buf.Add buf.Count, "\b"
Case f
buf.Add buf.Count, "\f"
Case r
buf.Add buf.Count, "\r"
Case n
buf.Add buf.Count, "\n"
Case t
buf.Add buf.Count, "\t"
Case Else
If AscW(c) >= 0 And AscW(c) <= 31 Then
c = Right("0" & Hex(AscW(c)), 2)
buf.Add buf.Count, "\u00" & c
Else
buf.Add buf.Count, c
End If
End Select
Next
buf.Add buf.Count, """"
Case vbArray + vbVariant
g = True
buf.Add buf.Count, "["
For Each i In obj
If g Then g = False Else buf.Add buf.Count, ","
buf.Add buf.Count, Encode(i)
Next
buf.Add buf.Count, "]"
Case vbObject
If TypeName(obj) = "Dictionary" Then
g = True
buf.Add buf.Count, "{"
For Each i In obj
If g Then g = False Else buf.Add buf.Count, ","
buf.Add buf.Count, """" & i & """" & ":" & Encode(obj(i))
Next
buf.Add buf.Count, "}"
Else
Err.Raise 8732, , "None dictionary object"
End If
Case Else
buf.Add buf.Count, """" & CStr(obj) & """"
End Select
Encode = Join(buf.Items, "")
End Function

'Return the VBScript representation of ``str(``
'Performs the following translations in decoding
'+---------------+-------------------+
'| JSON          | VBScript          |
'+===============+===================+
'| object        | Dictionary        |
'+---------------+-------------------+
'| array         | Array             |
'+---------------+-------------------+
'| string        | String            |
'+---------------+-------------------+
'| number        | Double            |
'+---------------+-------------------+
'| true          | True              |
'+---------------+-------------------+
'| false         | False             |
'+---------------+-------------------+
'| null          | Null              |
'+---------------+-------------------+
Public Function Decode(ByRef str)
Dim idx
idx = SkipWhitespace(str, 1)

If mid(str, idx, 1) = "{" Then
Set Decode = ScanOnce(str, 1)
Else
Decode = ScanOnce(str, 1)
End If
End Function

Private Function ScanOnce(ByRef str, ByRef idx)
Dim c, ms

idx = SkipWhitespace(str, idx)
c = mid(str, idx, 1)

If c = "{" Then
idx = idx + 1
Set ScanOnce = ParseObject(str, idx)
Exit Function
ElseIf c = "[" Then
idx = idx + 1
ScanOnce = ParseArray(str, idx)
Exit Function
ElseIf c = """" Then
idx = idx + 1
ScanOnce = ParseString(str, idx)
Exit Function
ElseIf c = "n" And StrComp("null", mid(str, idx, 4)) = 0 Then
idx = idx + 4
ScanOnce = Null
Exit Function
ElseIf c = "t" And StrComp("true", mid(str, idx, 4)) = 0 Then
idx = idx + 4
ScanOnce = True
Exit Function
ElseIf c = "f" And StrComp("false", mid(str, idx, 5)) = 0 Then
idx = idx + 5
ScanOnce = False
Exit Function
End If

Set ms = NumberRegex.Execute(mid(str, idx))
If ms.Count = 1 Then
idx = idx + ms(0).Length
ScanOnce = CDbl(ms(0))
Exit Function
End If

Err.Raise 8732, , "No JSON object could be ScanOnced"
End Function

Private Function ParseObject(ByRef str, ByRef idx)
Dim c, key, value
Set ParseObject = CreateObject("Scripting.Dictionary")
idx = SkipWhitespace(str, idx)
c = mid(str, idx, 1)

If c = "}" Then
Exit Function
ElseIf c <> """" Then
Err.Raise 8732, , "Expecting property name"
End If

idx = idx + 1

Do
key = ParseString(str, idx)

idx = SkipWhitespace(str, idx)
If mid(str, idx, 1) <> ":" Then
Err.Raise 8732, , "Expecting : delimiter"
End If

idx = SkipWhitespace(str, idx + 1)
If mid(str, idx, 1) = "{" Then
Set value = ScanOnce(str, idx)
Else
value = ScanOnce(str, idx)
End If
ParseObject.Add key, value

idx = SkipWhitespace(str, idx)
c = mid(str, idx, 1)
If c = "}" Then
Exit Do
ElseIf c <> "," Then
Err.Raise 8732, , "Expecting , delimiter"
End If

idx = SkipWhitespace(str, idx + 1)
c = mid(str, idx, 1)
If c <> """" Then
Err.Raise 8732, , "Expecting property name"
End If

idx = idx + 1
Loop

idx = idx + 1
End Function

Private Function ParseArray(ByRef str, ByRef idx)
Dim c, values, value
Set values = CreateObject("Scripting.Dictionary")
idx = SkipWhitespace(str, idx)
c = mid(str, idx, 1)

If c = "]" Then
ParseArray = values.Items
Exit Function
End If

Do
idx = SkipWhitespace(str, idx)
If mid(str, idx, 1) = "{" Then
Set value = ScanOnce(str, idx)
Else
value = ScanOnce(str, idx)
End If
values.Add values.Count, value

idx = SkipWhitespace(str, idx)
c = mid(str, idx, 1)
If c = "]" Then
Exit Do
ElseIf c <> "," Then
Err.Raise 8732, , "Expecting , delimiter"
End If

idx = idx + 1
Loop

idx = idx + 1
ParseArray = values.Items
End Function

Private Function ParseString(ByRef str, ByRef idx)
Dim chunks, content, terminator, ms, esc, char
Set chunks = CreateObject("Scripting.Dictionary")

Do
Set ms = StringChunk.Execute(mid(str, idx))
If ms.Count = 0 Then
Err.Raise 8732, , "Unterminated string starting"
End If

content = ms(0).Submatches(0)
terminator = ms(0).Submatches(1)
If Len(content) > 0 Then
chunks.Add chunks.Count, content
End If

idx = idx + ms(0).Length

If terminator = """" Then
Exit Do
ElseIf terminator <> "\" Then
Err.Raise 8732, , "Invalid control character"
End If

esc = mid(str, idx, 1)

If esc <> "u" Then
Select Case esc
Case """"
char = """"
Case "\"
char = "\"
Case "/"
char = "/"
Case "b"
char = b
Case "f"
char = f
Case "n"
char = n
Case "r"
char = r
Case "t"
char = t
Case Else
Err.Raise 8732, , "Invalid escape"
End Select
idx = idx + 1
Else
char = ChrW("&H" & mid(str, idx + 1, 4))
idx = idx + 5
End If

chunks.Add chunks.Count, char
Loop

ParseString = Join(chunks.Items, "")
End Function

Private Function SkipWhitespace(ByRef str, ByVal idx)
Do While idx <= Len(str) And _
InStr(Whitespace, mid(str, idx, 1)) > 0
idx = idx + 1
Loop
SkipWhitespace = idx
End Function

'End Class