POST请求无响应：原可用VBA数据爬取宏失效排查求助

问题背景 #

此前可正常运行的VBA宏（用于从investing.com爬取历史数据），当前执行POST请求后无响应。宏运行时无数据显示，也未弹出任何报错信息，关闭防火墙后问题仍存在，需排查数据流阻塞原因。

原代码 #

Option Explicit
Sub Export_Table()

'Html Objects---------------------------------------'
 Dim htmlDoc As MSHTML.HTMLDocument
 Dim htmlBody As MSHTML.htmlBody
 Dim ieTable As MSHTML.HTMLTable
 Dim Element As MSHTML.HTMLElementCollection


'Workbooks, Worksheets, Ranges, LastRow, Incrementers ----------------'
 Dim wb As Workbook
 Dim Table As Worksheet
 Dim i As Long

 Set wb = ThisWorkbook
 Set Table = wb.Worksheets("Sheet1")

 '-------------------------------------------'
 Dim xmlHttpRequest As New MSXML2.XMLHTTP60  '
 '-------------------------------------------'


 i = 2

'Web Request --------------------------------------------------------------------------'
 With xmlHttpRequest
 .Open "POST", "https://www.investing.com/instruments/HistoricalDataAjax", False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.setRequestHeader "X-Requested-With", "XMLHttpRequest"
.send "curr_id=951681&smlID=1695217&header=CLNX+Historical+Data&st_date=01%2F01%2F2021&end_date=03%2F01%2F2023&interval_sec=Monthly&sort_col=date&sort_ord=DESC&action=historical_data"


 If .Status = 200 Then

        Set htmlDoc = CreateHTMLDoc
        Set htmlBody = htmlDoc.body

        htmlBody.innerHTML = xmlHttpRequest.responseText

        Set ieTable = htmlDoc.getElementById("curr_table")

        For Each Element In ieTable.getElementsByTagName("tr")
            Table.Cells(i, 1) = Element.Children(0).innerText
            Table.Cells(i, 2) = Element.Children(1).innerText
            Table.Cells(i, 3) = Element.Children(2).innerText
            Table.Cells(i, 4) = Element.Children(3).innerText
            Table.Cells(i, 5) = Element.Children(4).innerText
            Table.Cells(i, 6) = Element.Children(5).innerText
            Table.Cells(i, 7) = Element.Children(6).innerText

            i = i + 1
        DoEvents: Next Element
 End If
End With


Set xmlHttpRequest = Nothing
Set htmlDoc = Nothing
Set htmlBody = Nothing
Set ieTable = Nothing
Set Element = Nothing

End Sub

Public Function CreateHTMLDoc() As MSHTML.HTMLDocument
    Set CreateHTMLDoc = CreateObject("htmlfile")
End Function

阻塞原因排查及修复方案 #

1. 请求头缺失触发反爬拦截

Investing.com的反爬机制可能已更新，仅靠Content-Type和X-Requested-With无法通过验证，需补充浏览器标识类请求头：

• 添加User-Agent：模拟真实浏览器请求
• 添加Referer：表明请求来源页面，符合网站访问逻辑

2. POST参数格式错误

原代码中POST参数使用了HTML转义的&，实际POST请求需用&作为参数分隔符，否则服务器无法正确解析参数。

3. 未处理空对象及越界错误

原代码未判断curr_table是否存在，也未检查表格行的子元素数量，若响应结构变化会导致静默失败。

4. 调试信息缺失

原代码未输出请求状态和响应内容，无法判断是请求未发送成功还是响应解析失败。

修复后的代码 #

Option Explicit
Sub Export_Table()
    'Html Objects
    Dim htmlDoc As MSHTML.HTMLDocument
    Dim htmlBody As MSHTML.htmlBody
    Dim ieTable As MSHTML.HTMLTable
    Dim Element As MSHTML.IHTMLElement '修正元素类型，遍历<tr>需用单个元素对象
    
    'Workbooks, Worksheets, Ranges
    Dim wb As Workbook
    Dim Table As Worksheet
    Dim i As Long
    
    Set wb = ThisWorkbook
    Set Table = wb.Worksheets("Sheet1")
    
    Dim xmlHttpRequest As New MSXML2.XMLHTTP60
    i = 2
    
    'Web Request
    With xmlHttpRequest
        .Open "POST", "https://www.investing.com/instruments/HistoricalDataAjax", False
        '补充必要请求头，模拟浏览器行为
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .setRequestHeader "X-Requested-With", "XMLHttpRequest"
        .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/114.0.0.0 Safari/537.36"
        .setRequestHeader "Referer", "https://www.investing.com/indices/clnx-historical-data"
        
        '修正参数分隔符，将&amp;替换为&
        .send "curr_id=951681&smlID=1695217&header=CLNX+Historical+Data&st_date=01%2F01%2F2021&end_date=03%2F01%2F2023&interval_sec=Monthly&sort_col=date&sort_ord=DESC&action=historical_data"
        
        '调试输出，查看请求状态和响应内容，方便排查
        Debug.Print "请求状态码：" & .Status
        Debug.Print "响应内容：" & .responseText
        
        If .Status = 200 Then
            Set htmlDoc = CreateHTMLDoc
            Set htmlBody = htmlDoc.body
            htmlBody.innerHTML = .responseText
            
            Set ieTable = htmlDoc.getElementById("curr_table")
            '先判断目标表格是否存在
            If Not ieTable Is Nothing Then
                For Each Element In ieTable.getElementsByTagName("tr")
                    '判断子元素数量，避免赋值时越界报错
                    If Element.Children.Length >= 7 Then
                        Table.Cells(i, 1) = Element.Children(0).innerText
                        Table.Cells(i, 2) = Element.Children(1).innerText
                        Table.Cells(i, 3) = Element.Children(2).innerText
                        Table.Cells(i, 4) = Element.Children(3).innerText
                        Table.Cells(i, 5) = Element.Children(4).innerText
                        Table.Cells(i, 6) = Element.Children(5).innerText
                        Table.Cells(i, 7) = Element.Children(6).innerText
                        i = i + 1
                    End If
                    DoEvents
                Next Element
            Else
                MsgBox "未找到目标表格：curr_table，请检查响应结构是否更新"
            End If
        Else
            MsgBox "请求失败，状态码：" & .Status
        End If
    End With
    
    '清理对象
    Set xmlHttpRequest = Nothing
    Set htmlDoc = Nothing
    Set htmlBody = Nothing
    Set ieTable = Nothing
    Set Element = Nothing
End Sub

Public Function CreateHTMLDoc() As MSHTML.HTMLDocument
    Set CreateHTMLDoc = CreateObject("htmlfile")
End Function

额外排查建议 #

• 若仍无响应，尝试改用MSXML2.ServerXMLHTTP60对象，部分环境下该对象的请求优先级更高
• 检查curr_id和smlID是否过期，可手动打开目标页面，通过浏览器开发者工具查看最新的请求参数
• 若网站启用了Cookie验证，需在请求中携带有效Cookie，可先通过浏览器访问页面获取Cookie后添加到请求头中

内容的提问来源于stack exchange，提问作者red