网页取行情数据-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