运行VBA网页自动化代码时出现Run-time error -2147023170错误求助

问题描述 #

运行VBA网页自动化代码时触发错误：Run-time error -2147023170 (800706be): Automation error, the remote procedure call failed，错误出现在Do While ie.Busy Or ie.readyState <> 4行，替换为READYSTATE_COMPLETE也无法解决。代码功能为从Excel工作表读取数值，传入网页计算后将结果提取回Excel。

原代码如下：

Sub WebAutomation()
 
    Dim ie As Object
    Dim html As Object
    Dim inputFilePath As String
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim resultSheet As Worksheet
    Dim lastRow As Long
    Dim number1 As String
    Dim number2 As String
    Dim additionResult As String
    Dim subtractionResult As String
    Dim multiplicationResult As String
    Dim divisionResult As String
    Dim i As Long
    Dim startTime As Single
 
    ' 定义输入文件路径并打开工作簿
    inputFilePath = "C:\Users\lenovo\Documents\Calculator.xlsx" ' 修改为你的实际文件路径
    Set wb = Workbooks.Open(inputFilePath)
    Set ws = wb.Sheets("Sheet1")
    
    ' 创建结果工作表
    On Error Resume Next
    Application.DisplayAlerts = False
    wb.Sheets("Results").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    Set resultSheet = wb.Sheets.Add
    resultSheet.Name = "Results"
    resultSheet.Range("A1:F1").Value = Array("数字1", "数字2", "加法结果", "减法结果", "乘法结果", "除法结果")
    
    ' 初始化IE浏览器
    Set ie = CreateObject("InternetExplorer.Application")
    ie.Visible = True
    ie.FullScreen = True ' 最大化浏览器窗口
    
    ' 获取数据最后一行
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    ' 遍历每行数据
    For i = 2 To lastRow ' 假设第一行为表头
        number1 = ws.Cells(i, 1).Value
        number2 = ws.Cells(i, 2).Value
        
        ' 导航到目标网页
        ie.Navigate "https://www.automationandagile.com/p/demo-page.html"
        
        ' 等待页面加载
        Do While ie.Busy Or ie.readyState <> 4
            DoEvents
        Loop
        
        ' 等待输入元素加载完成
        startTime = Timer
        Do While Timer - startTime < 10
            On Error Resume Next
            Set html = ie.document
            If Not html Is Nothing Then
                If Not html.getElementById("num1") Is Nothing Then Exit Do
            End If
            On Error GoTo 0
            DoEvents
        Loop
        
        If html Is Nothing Or html.getElementById("num1") Is Nothing Then
            MsgBox "无法加载网页或找到输入元素。", vbCritical
            Exit Sub
        End If
        
        ' 填充表单并提交计算
        html.getElementById("num1").Value = number1
        html.getElementById("num2").Value = number2
        html.getElementById("btnCalculate").Click
        Application.Wait Now + TimeValue("00:00:02") ' 等待结果加载
        
        ' 提取计算结果
        On Error Resume Next
        additionResult = html.getElementById("lblAdd").innerText
        subtractionResult = html.getElementById("lblSub").innerText
        multiplicationResult = html.getElementById("lblMult").innerText
        divisionResult = html.getElementById("lblDiv").innerText
        On Error GoTo 0
        
        ' 将结果保存到工作表
        resultSheet.Cells(i, 1).Value = number1
        resultSheet.Cells(i, 2).Value = number2
        resultSheet.Cells(i, 3).Value = additionResult
        resultSheet.Cells(i, 4).Value = subtractionResult
        resultSheet.Cells(i, 5).Value = multiplicationResult
        resultSheet.Cells(i, 6).Value = divisionResult
    Next i
    
    ' 关闭IE浏览器
    ie.Quit
    
    ' 保存结果工作簿
    wb.SaveAs Filename:=Left(inputFilePath, InStrRev(inputFilePath, ".") - 1) & "_results.xlsx", FileFormat:=xlOpenXMLWorkbook
    wb.Close
    
    MsgBox "数据提取与计算完成！", vbInformation
 
End Sub

错误原因及修复方案 #

1. 避免循环内重复导航页面 #

原代码在循环中每次迭代都重新加载网页，频繁的页面请求会导致IE自动化接口的RPC连接不稳定，触发错误。将页面导航移至循环外，仅加载一次页面，循环内仅更新输入值并提交计算。

修改后的核心代码片段：

' 移到循环外，仅导航一次页面
ie.Navigate "https://www.automationandagile.com/p/demo-page.html"

' 等待页面加载完成
Do While ie.Busy Or ie.readyState <> 4
    DoEvents
Loop

' 等待输入元素加载完成
startTime = Timer
Do While Timer - startTime < 10
    On Error Resume Next
    Set html = ie.document
    If Not html Is Nothing Then
        If Not html.getElementById("num1") Is Nothing Then Exit Do
    End If
    On Error GoTo 0
    DoEvents
Loop

If html Is Nothing Or html.getElementById("num1") Is Nothing Then
    MsgBox "无法加载网页或找到输入元素。", vbCritical
    Exit Sub
End If

' 循环内仅处理输入和结果提取
For i = 2 To lastRow
    number1 = ws.Cells(i, 1).Value
    number2 = ws.Cells(i, 2).Value
    
    ' 清空之前的输入值
    html.getElementById("num1").Value = ""
    html.getElementById("num2").Value = ""
    DoEvents
    
    ' 填充新数值
    html.getElementById("num1").Value = number1
    html.getElementById("num2").Value = number2
    html.getElementById("btnCalculate").Click
    
    ' 等待结果加载（替代固定2秒等待）
    startTime = Timer
    Do While Timer - startTime < 10
        On Error Resume Next
        If html.getElementById("lblAdd").innerText <> "" Then Exit Do
        On Error GoTo 0
        DoEvents
    Loop
    
    ' 提取结果
    On Error Resume Next
    additionResult = html.getElementById("lblAdd").innerText
    subtractionResult = html.getElementById("lblSub").innerText
    multiplicationResult = html.getElementById("lblMult").innerText
    divisionResult = html.getElementById("lblDiv").innerText
    On Error GoTo 0
    
    ' 保存结果到工作表
    resultSheet.Cells(i, 1).Value = number1
    resultSheet.Cells(i, 2).Value = number2
    resultSheet.Cells(i, 3).Value = additionResult
    resultSheet.Cells(i, 4).Value = subtractionResult
    resultSheet.Cells(i, 5).Value = multiplicationResult
    resultSheet.Cells(i, 6).Value = divisionResult
Next i

2. 优化页面等待逻辑 #

原固定等待2秒的方式不可靠，且直接判断ie.Busy和readyState时未捕获异常，容易触发RPC调用失败。可以封装一个带错误处理的等待函数：

' 封装IE等待函数，带超时处理和错误捕获
Sub WaitForIE(ie As Object, Optional timeoutSec As Integer = 10)
    Dim startTime As Single
    startTime = Timer
    Do
        On Error Resume Next
        Dim isBusy As Boolean, readyState As Integer
        isBusy = ie.Busy
        readyState = ie.readyState
        On Error GoTo 0
        If Not isBusy And readyState = 4 Then Exit Do
        DoEvents
    Loop While Timer - startTime < timeoutSec
End Sub

调用时直接替换原等待循环：

ie.Navigate "https://www.automationandagile.com/p/demo-page.html"
WaitForIE ie ' 使用封装的等待函数

3. 确保IE对象正确释放 #

在代码结束或错误分支中，确保IE对象被正确退出并释放，避免残留进程占用资源导致后续调用出错：

' 退出IE并释放对象
On Error Resume Next
ie.Quit
Set ie = Nothing
Set html = Nothing
On Error GoTo 0

4. 检查系统RPC服务状态 #

如果以上代码修改后仍报错，检查系统的**Remote Procedure Call (RPC)**服务是否正常运行：

• 按下Win+R，输入services.msc打开服务管理器
• 找到「Remote Procedure Call (RPC)」，确认状态为「正在运行」
• 若未运行，右键点击启动服务

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