VBA遍历超链接集合时抛出运行时错误70权限被拒绝问题求助

你代码的报错根源是动态DOM集合的绑定特性：你第一次从全局m_html对象中提取的elements链接集合不是静态独立的数据，而是和m_html对应的DOM文档动态绑定的引用集合。在循环内调用GetHTML时，GetHTML内部执行了Set m_html = New MSHTML.HTMLDocument重写了全局DOM对象，直接销毁了elements集合依赖的原始DOM结构，导致集合内存储的e元素引用全部失效，第二次循环访问e.href时就会抛出"权限被拒绝"或对象未初始化的错误。

按照以下两个步骤修改即可解决问题：

1. 提前存储静态链接列表 #

不要直接遍历绑定DOM的元素集合，先把所有需要的链接提取为独立的字符串集合，完全脱离原始DOM的依赖：

' 原有获取列表页逻辑不变
GetHTML strURL

' 新增：提取所有链接为静态字符串集合，不绑定DOM
Dim elements As IHTMLElementCollection
Dim e As IHTMLElement
Dim allLinks As New Collection
Set elements = m_html.getElementsByTagName("a")
For Each e In elements
    allLinks.Add e.href
Next e

' 后续遍历静态集合而非DOM元素
Dim href As Variant
For Each href In allLinks
    Debug.Print "Checking file at " & href
    If InStr(1, href, "index.htm", 1) > 0 And InStr(1, href, "archive", 1) > 0 Then
        ' 调用修改后的GetHTML函数，获取独立的DOM对象
        Dim archiveHtml As MSHTML.HTMLDocument
        Set archiveHtml = GetHTML(CStr(href))
        If Not archiveHtml Is Nothing Then
            Dim documents As IHTMLElementCollection
            Dim d As IHTMLElement
            Dim iCol As Integer
            Set documents = archiveHtml.getElementsByTagName("div")
            iCol = Excel.WorksheetFunction.Match("dateFiling", m_wsBuffer.Rows(1), 0)
            For Each d In documents
                If d.className = "infoHead" And d.innerText = "Filing Date" Then
                    m_wsBuffer.Cells(2, iCol) = d.innerText
                    Exit For
                End If
            Next d
        End If
    End If
Next href

2. 改造GetHTML为独立返回函数 #

取消全局m_html的复用，改为每次请求返回独立的HTMLDocument对象，避免不同请求的DOM互相干扰，同时添加请求头避免SEC反爬拦截：

Public Function GetHTML(strUrl As String) As MSHTML.HTMLDocument
    On Error GoTo ErrorHandler
    
    Dim x As MSXML2.XMLHTTP60
    Set x = New MSXML2.XMLHTTP60
    Set GetHTML = New MSHTML.HTMLDocument
    
    With x
        .Open "GET", strUrl, False
        ' 添加浏览器UA头，避免SEC反爬直接拦截请求
        .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"
        .send
        If .readyState = 4 And .Status = 200 Then
            GetHTML.body.innerHTML = .responseText
        Else
            Debug.Print "请求错误" & vbNewLine & "就绪状态: " & .readyState & _
            vbNewLine & "HTTP状态码: " & .Status
            Set GetHTML = Nothing
        End If
    End With
    
    Exit Function
    
ErrorHandler:
    If Err.Number <> 91 Then
        Debug.Print "GetHTML错误: " & Err.Number & ": " & Err.Description
        Set GetHTML = Nothing
    End If
End Function

EDGAR平台有请求频率限制，建议在每次请求后添加1-2秒的等待逻辑Application.Wait Now + TimeValue("00:00:01")，避免被临时封禁IP。

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