Excel RTD服务器无响应弹窗的VBA错误处理与邮件告警需求

当前方案的问题 #

你现在用的Workbook_SheetCalculate事件错误处理无法捕获目标弹窗。原因是：

• 这个事件里的On Error只能捕获VBA代码执行过程中产生的错误；
• 而"实时服务器‘RTDServer.Class’无响应"是Excel与RTD服务器交互时触发的系统级模态对话框，不属于VBA代码错误，不会触发VBA的错误捕获逻辑。

可行的实现方案 #

由于目标弹窗是Excel的系统级对话框，需要结合定时检测+窗口查找的方式来处理，具体步骤如下：

1. 核心思路 #

• 用Application.OnTime设置定时任务，每隔一段时间检测是否出现目标弹窗；
• 通过Windows API查找弹窗窗口，判断是否存在；
• 若检测到弹窗，自动关闭它，并触发邮件告警；
• 循环执行定时任务，持续监控。

2. 完整代码实现 #

首先在标准模块中添加以下代码：

'API声明，用于查找窗口和发送关闭消息
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As Long
Private Const WM_CLOSE As Long = &H10

'全局变量存储定时任务的时间，用于取消任务
Private nextCheckTime As Date

Sub StartRTDMonitor()
    '设置每隔30秒检测一次（可根据需求调整）
    nextCheckTime = Now + TimeValue("00:00:30")
    Application.OnTime nextCheckTime, "CheckRTDPopup"
    
    '可选：工作簿打开时自动启动监控，可放到Workbook_Open事件中
    MsgBox "RTD监控已启动", vbInformation
End Sub

Sub StopRTDMonitor()
    '取消定时任务
    On Error Resume Next
    Application.OnTime nextCheckTime, "CheckRTDPopup", , False
    On Error GoTo 0
    MsgBox "RTD监控已停止", vbInformation
End Sub

Sub CheckRTDPopup()
    Dim hwnd As LongPtr
    '查找目标弹窗窗口（窗口标题需完全匹配）
    hwnd = FindWindow(vbNullString, "Microsoft Excel")
    
    If hwnd <> 0 Then
        '获取窗口文本，确认是否是目标弹窗
        Dim windowText As String * 256
        GetWindowText hwnd, windowText, 256
        windowText = Left(windowText, InStr(windowText, vbNullChar) - 1)
        
        If InStr(windowText, "实时服务器‘RTDServer.Class’无响应") > 0 Then
            '关闭弹窗
            SendMessage hwnd, WM_CLOSE, 0, 0
            '触发邮件告警
            SendEmailAlert
        End If
    End If
    
    '继续设置下一次检测
    nextCheckTime = Now + TimeValue("00:00:30")
    Application.OnTime nextCheckTime, "CheckRTDPopup"
End Sub

'补充GetWindowText的API声明
Private Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal cch As Long) As Long

Sub SendEmailAlert()
    '这里替换为你的邮件发送逻辑，示例用Outlook发送
    Dim olApp As Object
    Dim olMail As Object
    
    On Error Resume Next
    Set olApp = CreateObject("Outlook.Application")
    Set olMail = olApp.CreateItem(0)
    
    With olMail
        .To = "告警接收邮箱@xxx.com"
        .Subject = "RTD服务器无响应告警"
        .Body = "检测到RTD服务器‘RTDServer.Class’无响应弹窗，已自动关闭。" & vbCrLf & "时间：" & Now
        .Send
    End With
    
    Set olMail = Nothing
    Set olApp = Nothing
End Sub

然后在ThisWorkbook模块中添加启动逻辑：

Private Sub Workbook_Open()
    '工作簿打开时自动启动监控
    StartRTDMonitor
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    '工作簿关闭时停止监控
    StopRTDMonitor
End Sub

3. 注意事项 #

• 需确保Excel启用宏，且信任对VBA项目对象模型的访问（文件选项→信任中心→信任中心设置→宏设置→勾选"信任对VBA项目对象模型的访问"）；
• 若使用Outlook发送邮件，需确保Outlook已登录，且允许宏访问；
• 窗口标题匹配需准确，若弹窗标题有差异，需调整InStr判断的文本内容；
• 检测间隔可根据需求调整，比如改为1分钟（TimeValue("00:01:00")）。

备选方案（若能自定义RTD服务器） #

如果是你自己开发的RTD服务器，可以在RTD服务器的ServerTerminate或Heartbeat方法中添加错误处理，直接触发VBA的邮件告警逻辑，这种方式更精准，无需定时检测。

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