VBA网页解析程序运行报Run-time error 5错误排查

问题描述 #

• 自行编写的网站解析VBA程序此前运行正常，近期运行时抛出如下错误：

Run-time error 5
Invalid procedure call or argument

• 报错定位到的代码行为：

sResponse = Mid$(sResponse, InStr(1, sResponse, "<!DOCTYPE "))

• 已尝试修改Windows系统语言设置，问题未解决，初步判断为目标网站页面代码变更导致。
• 程序完整原代码如下：

Sub Softочки()
Application.DisplayAlerts = False
Call mainмассивы
Application.DisplayAlerts = True
End Sub


Sub mainмассивы()
    Dim r As Range
    Dim iLoop As Long
    Dim book1 As Workbook
    Dim Ssilka As String
    Dim A As Long
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    Set book1 = Workbooks.Open("D:\Super M\Адаптация к сайту\таблица.xlsm")
     
   
     
        With book1.Worksheets("таблица").Range("B34:B53")
           iLoop = 0
             For Each r In .Rows
              
            
                  iLoop = iLoop + 1
                  Ssilka = r.Hyperlinks.Item(1).Address
                  book1.Worksheets("Лист" & iLoop).Activate
                  extractTable Ssilka, book1, iLoop
              
            Next r
        End With
  
  book1.Save
  book1.Close
  
  Application.ScreenUpdating = True
  Application.Calculation = xlCalculationAutomatic
  Application.EnableEvents = True
  
   End Sub


Function extractTable(Ssilka As String, book1 As Workbook, iLoop As Long)
    Dim oDom As Object, oTable As Object, oRow As Object
    Dim iRows As Integer, iCols As Integer
    Dim x As Integer, y As Integer
    Dim data()
    Dim vata()
    Dim tata()
    Dim oHttp As Object
    Dim oRegEx As Object
    Dim sResponse As String
    Dim oRange As Range
    Dim odRange As Range
    
    ' get page
    Set oHttp = CreateObject("MSXML2.XMLHTTP")
    oHttp.Open "GET", Ssilka, False
    oHttp.Send
    
    ' cleanup response
    sResponse = StrConv(oHttp.responseBody, vbUnicode)
    Set oHttp = Nothing
    
    sResponse = Mid$(sResponse, InStr(1, sResponse, "<!DOCTYPE "))
    
    Set oRegEx = CreateObject("vbscript.regexp")
    With oRegEx
        .MultiLine = True
        .Global = True
        .IgnoreCase = False
        .Pattern = "<(script|SCRIPT)[\w\W]+?</\1>"
        sResponse = .Replace(sResponse, "")
    End With
    Set oRegEx = Nothing
    
    ' create Document from response
    Set oDom = CreateObject("htmlFile")
    oDom.Write sResponse
    DoEvents
    
    ' table with results, indexes starts with zero
    Set oTable = oDom.getelementsbytagname("table")(3)
    
    DoEvents
    
    iRows = oTable.Rows.Length
    iCols = oTable.Rows(1).Cells.Length
    
    ' first row and first column contain no intresting data
    ReDim data(1 To iRows - 1, 1 To iCols - 1)
    ReDim vata(1 To iRows - 1, 1 To iCols - 1)
    ReDim tata(1 To iRows - 1, 1 To iCols - 1)
    ' fill in data array
    For x = 1 To iRows - 1
        Set oRow = oTable.Rows(x)
        
        For y = 1 To iCols - 1
             If oRow.Cells(y).Children.Length > 0 Then
                data(x, y) = oRow.Cells(y).getelementsbytagname("a")(0).getattribute("href")
                    data(x, y) = Replace(data(x, y), "about:", "http://allscores.ru/soccer/")
                vata(x, y) = oRow.Cells(y).innerText
                
            End If

        Next y
    Next x
    
    Set oRow = Nothing
    Set oTable = Nothing
    Set oDom = Nothing
    
   
    Set odRange = book1.ActiveSheet.Cells(34, 2).Resize(iRows - 1, iCols - 1)
    odRange.NumberFormat = "@"
    odRange.Value = vata
    
    
    Set odRange = Nothing
    
   
End Function

故障根因 #

错误5的直接触发原因是InStr(1, sResponse, "<!DOCTYPE ")未在响应字符串中匹配到对应内容，返回值为0，而Mid$函数的第二个起始位置参数不允许为0，因此抛出无效参数错误。
匹配失败的常见诱因：

• 旧版MSXML2.XMLHTTP对象未携带浏览器标识，被网站反爬拦截，返回了无标准DOCTYPE的异常响应页（如拦截提示、跳转页）
• 手动用StrConv转码时出现编码识别错误，导致字符串内容乱码，无法匹配到<!DOCTYPE 字段
• 网站更新页面后，DOCTYPE标签大小写变化、前面新增BOM头/空白内容，或部分页面直接省略DOCTYPE以<html>标签开头，原硬编码精确匹配逻辑失效

修复方案 #

按以下步骤修改代码即可解决问题：

1. 替换HTTP请求模块，改用更高版本的XMLHTTP对象，添加浏览器请求头避免被拦截，直接用responseText自动适配编码，替换原请求部分代码：

' 替换原get page、响应转码部分代码
Set oHttp = CreateObject("MSXML2.XMLHTTP.6.0")
oHttp.Open "GET", Ssilka, False
' 添加常规浏览器UA，避免被反爬识别拦截
oHttp.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/125.0.0.0 Safari/537.36"
oHttp.Send
' 等待请求加载完成
Do While oHttp.readyState <> 4
    DoEvents
Loop
' 直接获取自动转码后的响应文本，避免手动转码乱码
sResponse = oHttp.responseText
Set oHttp = Nothing

2. 替换原截断响应的代码，增加容错匹配，兼容无DOCTYPE、标签大小写变化的场景：

' 替换原sResponse = Mid$(sResponse, InStr(1, sResponse, "<!DOCTYPE "))行
Dim lContentStart As Long
' 忽略大小写匹配DOCTYPE
lContentStart = InStr(1, sResponse, "<!DOCTYPE ", vbTextCompare)
' 未匹配到DOCTYPE则匹配html起始标签
If lContentStart = 0 Then
    lContentStart = InStr(1, sResponse, "<html", vbTextCompare)
End If
' 匹配到有效起始位置再截断，避免参数为0报错
If lContentStart > 0 Then
    sResponse = Mid$(sResponse, lContentStart)
End If

3. 可选优化：将正则匹配的IgnoreCase属性设为True，去掉pattern里冗余的SCRIPT分支，提升脚本标签清理的兼容性：

With oRegEx
    .MultiLine = True
    .Global = True
    .IgnoreCase = True
    .Pattern = "<(script)[\w\W]+?</\1>"
    sResponse = .Replace(sResponse, "")
End With

若修复后出现表格索引报错，是因为网站页面结构调整后table标签的序号变化，按需调整getelementsbytagname("table")(3)里的索引值即可。

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