VBA网抓上海期货交易所数据

代码

Sub get_shfe_price_XMLHTTP60_NoDTS()
    Dim nowdate As String
    Dim yestoday As String
    Dim deliverymonthdate As String
    Dim URL As String
    Dim http As Object ' MSXML2.XMLHTTP60 对象
    Dim sourcecode As String
    Dim dom As Object ' DOM解析对象
    Dim tableNodes As Object ' 表格节点集合
    Dim tableNode As Object ' 单个表格节点
    Dim trNodes As Object ' 行节点集合
    Dim trNode As Object ' 单个行节点
    Dim tdNodes As Object ' 单元格节点集合
    Dim tdNode As Object ' 单个单元格节点
    Dim xpathQuery As String ' XPath查询语句
    Dim rowIndex As Integer ' 行索引
    Dim colIndex As Integer ' 列索引
    
    Dim dataDate As String
    Dim cufClosingPrice As Single
    Dim znfClosingPrice As Single
    Dim pbfClosingPrice As Single
    Dim agfClosingPrice As Single
    
    ' 1. 生成日期和URL
    deliverymonthdate = Format(Date + 60, "yymm")
    nowdate = Format(Date, "yyyymmdd")
    yestoday = Format(Date - 1, "yyyymmdd")

    URL = "https://www.shfe.com.cn/data/tradedata/future/dailydata/kx" & yestoday & ".dat"
    Debug.Print "请求URL：" & URL
    Debug.Print "请求日期：" & yestoday
    
    ' 2. 初始化MSXML2.XMLHTTP60对象
    On Error Resume Next
    Set http = CreateObject("MSXML2.XMLHTTP.6.0")
    On Error GoTo 0
    If http Is Nothing Then
        MsgBox "无法创建XMLHTTP60对象！请安装MSXML 6.0组件。", vbCritical
        Exit Sub
    End If
    
    ' 3. 发送HTTP请求
    With http
        .Open "GET", URL, False
        On Error Resume Next
        .setOption 2, 13056
        On Error GoTo 0
        .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/141.0.0.0 Safari/537.36 Edg/141.0.0.0"
        .setRequestHeader "Accept", "application/json, text/javascript, */*; q=0.01" ' 修改为接受JSON
        .setRequestHeader "Accept-Language", "zh-CN,zh;q=0.9,en;q=0.8"
        .setRequestHeader "Referer", "https://www.shfe.com.cn/"
        .send
        
        If .Status <> 200 Then
            MsgBox "请求失败！状态码：" & .Status & vbCrLf & "响应文本：" & Left(.responseText, 500), vbCritical
            Set http = Nothing
            Exit Sub
        End If
        sourcecode = .responseText
    End With
    Set http = Nothing
    Debug.Print "页面源码长度：" & Len(sourcecode)
    
    Application.Wait Now + TimeValue("00:00:01")
    
    ' 4. 检查数据
    If Len(sourcecode) = 0 Then
        MsgBox "未获取到数据！", vbExclamation
        Exit Sub
    End If
    
    Set oDom = CreateObject("htmlfile")
    Set oWindow = oDom.parentWindow
    ' 修正JSON解析代码
    On Error Resume Next
    oWindow.execScript "var jsonString = " & sourcecode & "; var s = JSON.parse(jsonString);"
    oWindow.execScript "var s = " & sourcecode

    Dim arrLength As Integer
    arrLength = oWindow.eval("s.o_curinstrument.length")
    Debug.Print "找到 " & arrLength & " 个品种:"
    
    Dim i As Integer
    For i = 0 To arrLength - 1
        ' 检查当前元素是否符合条件
        Dim currentProductId As String
        Dim currentDeliveryMonth As String
        
        currentProductId = oWindow.eval("s.o_curinstrument[" & i & "].PRODUCTID")
        currentDeliveryMonth = oWindow.eval("s.o_curinstrument[" & i & "].DELIVERYMONTH")
        
        ' 如果找到匹配的数据
        If currentProductId = "cu_f" And currentDeliveryMonth = deliverymonthdate Then
            cufClosingPrice = oWindow.eval("s.o_curinstrument[" & i & "].CLOSEPRICE")
        End If
        If currentProductId = "pb_f" And currentDeliveryMonth = deliverymonthdate Then
            pbfClosingPrice = oWindow.eval("s.o_curinstrument[" & i & "].CLOSEPRICE")
        End If
        If currentProductId = "zn_f" And currentDeliveryMonth = deliverymonthdate Then
            znfClosingPrice = oWindow.eval("s.o_curinstrument[" & i & "].CLOSEPRICE")
        End If
        If currentProductId = "ag_f" And currentDeliveryMonth = deliverymonthdate Then
            agfClosingPrice = oWindow.eval("s.o_curinstrument[" & i & "].CLOSEPRICE")
        End If
    Next i

    Debug.Print "铜收盘价: " & cufClosingPrice
    Debug.Print "铅收盘价: " & pbfClosingPrice
    Debug.Print "锌收盘价: " & znfClosingPrice
    Debug.Print "银收盘价: " & agfClosingPrice
    
    ' 释放对象
    Set records = Nothing
    Set json = Nothing
    Set tdNodes = Nothing
    Set trNodes = Nothing
    Set tableNodes = Nothing
    Set dom = Nothing

End Sub