找到
2
篇与
VBA
相关的结果
-
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
-
VBA网抓上海黄金交易所 简 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
