Win10更新后Excel VBA发WhatsApp报-2147023170自动化错误如何解决

报错Run-time '-2147023170 (800706be)': Automation error The remote procedure call failed的核心原因是Windows 10系统更新后微软全面禁用了Internet Explorer的自动化调用接口，你的原代码依赖InternetExplorer.ApplicationCOM对象启动WhatsApp协议，因此触发组件调用失败。

排查修复步骤 #

• 第一步：验证IE组件状态
  先运行以下测试代码确认故障根源：

Sub TestIEComponent()
Dim IE As Object
On Error Resume Next
Set IE = CreateObject("InternetExplorer.Application")
If Err.Number <> 0 Then
MsgBox "IE COM组件已被系统禁用，为故障根源，无需尝试修复IE直接改用替代方案即可"
Else
IE.Quit
Set IE = Nothing
MsgBox "IE组件正常，可检查WhatsApp默认打开配置是否异常"
End If
End Sub

微软已停止对IE的所有支持，系统更新强制禁用IE接口后修复成本极高且稳定性极差，直接替换IE调用逻辑即可解决问题。

- 第二步：替换IE调用逻辑为系统Shell调用
完全去掉IE相关代码，改用Windows原生Shell直接调用WhatsApp协议，无需依赖任何浏览器组件：
替换原代码中以下两行：
```vba
Set IE = CreateObject("InternetExplorer.Application")
IE.navigate strPostData

替换为：

Dim shell As Object
Set shell = CreateObject("Shell.Application")
shell.Open strPostData
Set shell = Nothing

• 第三步：优化代码稳定性（可选但强烈建议）
  Win10更新后窗口焦点逻辑调整，原SendKeys逻辑容易失效，可做两处优化：

  • 调用SendKeys前添加AppActivate "WhatsApp"强制激活WhatsApp窗口，避免焦点错位
  • 对消息内容做URL编码，避免特殊字符、空格、中文导致的传参错误
  • 适当调整等待时长，适配WhatsApp窗口加载速度

• 完整优化后的参考代码

Option Explicit
Sub WhatsAppMsg()
    Dim LastRow As Long
    Dim i As Integer
    Dim strPhoneNumber As String
    Dim strMessage As String
    Dim strPostData As String
    Dim shell As Object
    
    LastRow = Range("A" & Rows.Count).End(xlUp).Row
    Set shell = CreateObject("Shell.Application")
    
    For i = 2 To LastRow
        strPhoneNumber = Sheets("Sheet1").Cells(i, 1).Value
        strMessage = Sheets("Sheet1").Cells(i, 2).Value
        ' 对消息内容编码，避免特殊字符传参错误
        strPostData = "whatsapp://send?phone=" & strPhoneNumber & "&text=" & WorksheetFunction.EncodeURL(strMessage)
        
        ActiveSheet.Shapes(1).Copy
        shell.Open strPostData
        
        ' 等待窗口加载完成
        Application.Wait (Now + TimeValue("00:00:07"))
        ' 强制激活WhatsApp窗口
        AppActivate "WhatsApp"
        DoEvents
        
        SendKeys "^v", True
        Application.Wait (Now + TimeValue("00:00:03"))
        
        SendKeys "{ENTER}", True
        Application.Wait (Now + TimeValue("00:00:02"))
    Next i
    
    Set shell = Nothing
End Sub

• 额外注意事项
  • 运行代码前确保桌面版WhatsApp已登录，且被设置为whatsapp://协议的默认打开程序
  • 代码运行过程中不要操作鼠标键盘，避免窗口焦点被抢占导致SendKeys失效
  • 批量发送时建议加长循环间隔，避免WhatsApp判定行为异常触发封号

内容的提问来源于stack exchange，提问作者Mohamed El Habchi