VBA网抓上海黄金交易所
登录

VBA网抓上海黄金交易所

richfan
richfan
10月31日发布
0 1 0

简

Sub get_sge_price_XMLHTTP60_NoDTS()
    Dim nowdate As String
    Dim yestoday 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 contract As String
    ' Dim openingPrice As Single
    ' Dim highestPrice As Single
    ' Dim lowestPrice As Single
    Dim autdClosingPrice As Single
    Dim agtdClosingPrice As Single
    ' Dim riseAndFall As Single
    ' Dim priceRange As Single
    ' Dim weightedAveragePrice As Single
    ' Dim tradingVolume As Single
    ' Dim tradingAmount As Single
    
    
    ' 1. 生成日期和URL（保留原逻辑）
    nowdate = Format(Date, "yyyy-mm-dd")
    yestoday = Format(Date - 1, "yyyy-mm-dd")
    URL = "https://www.sge.com.cn/sjzx/quotation_daily_new?start_date=" & yestoday & "&end_date=" & yestoday
    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请求（补充SSL忽略配置）
    With http
        .Open "GET", URL, False
        On Error Resume Next
        .setOption 2, 13056 ' 仅XMLHTTP60支持，失败不报错
        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", "text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8"
        .setRequestHeader "Accept-Language", "zh-CN,zh;q=0.9,en;q=0.8"
        .setRequestHeader "Referer", "https://www.sge.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)
    If InStr(sourcecode, "daily_new_table") = 0 Then
        MsgBox "获取的源码中无'daily_new_table'，可能页面结构变更！", vbExclamation
        Exit Sub
    End If
    
    ' 4. 初始化HTMLFile解析对象（补充错误处理）
    On Error Resume Next
    Set dom = CreateObject("HTMLFile")
    On Error GoTo 0
    If dom Is Nothing Then
        MsgBox "无法创建HTMLFile解析对象！", vbCritical
        Exit Sub
    End If
    
    ' 5. 解析HTML源码（修正解析逻辑）
    dom.write "<!DOCTYPE html><html><body>" & sourcecode & "</body></html>"
    dom.Close
    Application.Wait Now + TimeValue("00:00:01") ' 短暂延迟确保解析完成
    Debug.Print "使用HTMLFile引擎解析（自动禁用DTS）"

    ' 定位目标表格（class+关键词兜底）
    Set tableNodes = dom.getElementsByClassName("daily_new_table")
    If tableNodes.Length = 0 Then
        Debug.Print "按class未找到，尝试按关键词定位表格..."
        Set tableNodes = dom.getElementsByTagName("table")
        For Each tableNode In tableNodes
            If InStr(tableNode.innerText, "开盘价") > 0 And InStr(tableNode.innerText, "收盘价") > 0 Then
                Set tableNodes = dom.createDocumentFragment
                tableNodes.appendChild tableNode
                Exit For
            End If
        Next tableNode
        If tableNodes.Length = 0 Then
            MsgBox "未找到目标表格！可能页面结构已变更。", vbExclamation
            Set dom = Nothing
            Exit Sub
        End If
    End If
    
    ' 取第一个目标表格的tbody
    Set tableNode = tableNodes(0)
    Set tableNodes = tableNode.getElementsByTagName("tbody")
    MsgBox tableNodes.Length ' 显示tbody数量
    
    ' 统计数据行数并遍历所有行和单元格（核心新增逻辑）
    rowIndex = 0
    If tableNodes.Length > 0 Then
        Set trNodes = tableNodes(0).getElementsByTagName("tr")
        rowIndex = trNodes.Length

        ' 新增：遍历所有行（trNode）和对应单元格（tdNode）
        Debug.Print vbCrLf & "=== 表格数据详情 ==="
        For Each trNode In trNodes
            Set tdNodes = trNode.getElementsByTagName("td") ' 获取当前行的所有单元格
            colIndex = 0
            
            For i = 1 To 5
                Select Case Trim(tdNodes(i).innerText)
                    Case "Au(T+D)"
                        dataDate = tdNodes(0).innerText
                        autdClosingPrice = tdNodes(5).innerText
                    Case "Ag(T+D)"
                        agtdClosingPrice = tdNodes(5).innerText
                End Select
            Next i
            
            ' 遍历当前行的单元格并打印到立即窗口
        Next trNode
    End If
    
    Debug.Print autdClosingPrice
    Debug.Print agtdClosingPrice
    
    ' 释放对象
    Set tdNodes = Nothing
    Set trNodes = Nothing
    Set tableNodes = Nothing
    Set dom = Nothing
    
    MsgBox "数据提取完成！共提取 " & rowIndex & " 行数据，请按Ctrl+G打开【立即窗口】查看详情。", vbInformation
End Sub

原

Sub get_sge_price_XMLHTTP60_NoDTS()
    Dim nowdate As String
    Dim yestoday 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 contract As String
    ' Dim openingPrice As Single
    ' Dim highestPrice As Single
    ' Dim lowestPrice As Single
    Dim autdClosingPrice As Single
    ' Dim riseAndFall As Single
    ' Dim priceRange As Single
    ' Dim weightedAveragePrice As Single
    ' Dim tradingVolume As Single
    ' Dim tradingAmount As Single
    
    
    ' 1. 生成日期和URL（保留原逻辑）
    nowdate = Format(Date, "yyyy-mm-dd")
    yestoday = Format(Date - 1, "yyyy-mm-dd")
    URL = "https://www.sge.com.cn/sjzx/quotation_daily_new?start_date=" & yestoday & "&end_date=" & yestoday
    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请求（补充SSL忽略配置）
    With http
        .Open "GET", URL, False
        On Error Resume Next
        .setOption 2, 13056 ' 仅XMLHTTP60支持，失败不报错
        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", "text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8"
        .setRequestHeader "Accept-Language", "zh-CN,zh;q=0.9,en;q=0.8"
        .setRequestHeader "Referer", "https://www.sge.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)
    If InStr(sourcecode, "daily_new_table") = 0 Then
        MsgBox "获取的源码中无'daily_new_table'，可能页面结构变更！", vbExclamation
        Exit Sub
    End If
    
    ' 4. 初始化HTMLFile解析对象（补充错误处理）
    On Error Resume Next
    Set dom = CreateObject("HTMLFile")
    On Error GoTo 0
    If dom Is Nothing Then
        MsgBox "无法创建HTMLFile解析对象！", vbCritical
        Exit Sub
    End If
    
    ' 5. 解析HTML源码（修正解析逻辑）
    dom.write "<!DOCTYPE html><html><body>" & sourcecode & "</body></html>"
    dom.Close
    Application.Wait Now + TimeValue("00:00:01") ' 短暂延迟确保解析完成
    Debug.Print "使用HTMLFile引擎解析（自动禁用DTS）"

    ' 定位目标表格（class+关键词兜底）
    Set tableNodes = dom.getElementsByClassName("daily_new_table")
    If tableNodes.Length = 0 Then
        Debug.Print "按class未找到，尝试按关键词定位表格..."
        Set tableNodes = dom.getElementsByTagName("table")
        For Each tableNode In tableNodes
            If InStr(tableNode.innerText, "开盘价") > 0 And InStr(tableNode.innerText, "收盘价") > 0 Then
                Set tableNodes = dom.createDocumentFragment
                tableNodes.appendChild tableNode
                Exit For
            End If
        Next tableNode
        If tableNodes.Length = 0 Then
            MsgBox "未找到目标表格！可能页面结构已变更。", vbExclamation
            Set dom = Nothing
            Exit Sub
        End If
    End If
    
    ' 取第一个目标表格的tbody
    Set tableNode = tableNodes(0)
    Set tableNodes = tableNode.getElementsByTagName("tbody")
    MsgBox tableNodes.Length ' 显示tbody数量
    
    ' 统计数据行数并遍历所有行和单元格（核心新增逻辑）
    rowIndex = 0
    If tableNodes.Length > 0 Then
        Set trNodes = tableNodes(0).getElementsByTagName("tr")
        rowIndex = trNodes.Length

        ' 新增：遍历所有行（trNode）和对应单元格（tdNode）
        Debug.Print vbCrLf & "=== 表格数据详情 ==="
        For Each trNode In trNodes
            Set tdNodes = trNode.getElementsByTagName("td") ' 获取当前行的所有单元格
            colIndex = 0
            Debug.Print "第 " & (rowIndex - trNodes.Length + 1) & " 行：" ' 行号输出
            ' 遍历当前行的单元格并打印到立即窗口
            For Each tdNode In tdNodes
                colIndex = colIndex + 1
                Debug.Print "  列" & colIndex & "：" & Trim(tdNode.innerText)
            Next tdNode
            dataDate = Trim(tdNodes(0).innerText)
        Next trNode
    End If
    
    ' 释放对象
    Set tdNodes = Nothing
    Set trNodes = Nothing
    Set tableNodes = Nothing
    Set dom = Nothing
    
    MsgBox "数据提取完成！共提取 " & rowIndex & " 行数据，请按Ctrl+G打开【立即窗口】查看详情。", vbInformation
End Sub
© 版权声明
文章版权归作者所有，未经允许请勿转载。
THE END
程技# VBA# 爬虫# 金属
喜欢就支持一下吧
点赞 0 分享 收藏
版权属于：richfan
本文链接：https://252262.xyz/index.php/archives/38/
作品采用《署名-非商业性使用-相同方式共享 4.0 国际 (CC BY-NC-SA 4.0)》许可协议授权
相关推荐
VBA网抓上海期货交易所数据
VBA网抓上海期货交易所数据
VBA网抓上海期货交易所数据
11月1日 6
评论 抢沙发
OωO
取消