使用VBA实现Outlook共享收件箱邮件规则自动执行及弹窗提醒

我在Outlook中有一个名为AES Sales的共享收件箱，已配置规则：当收到主题包含Fitness Club - FF或Fitness First FM的邮件时，将其移动至Job Tickets文件夹，并标记绿色和灰色颜色类别。但该规则无法自动触发，仅手动点击「立即运行规则」时才生效。

需求 #

• 让Outlook自动运行该规则；
• 新邮件到达时弹出提示框，且弹窗需在Excel、Chrome等其他应用前台显示（Outlook始终处于运行状态）。

已尝试的VBA代码 #

Sub RunAllInboxRules()
    Dim st As Outlook.Store
    Dim myRules As Outlook.Rules
    Dim rl As Outlook.Rule
    Dim count As Integer
    Dim ruleList As String
    'On Error Resume Next

    ' 获取默认存储（规则所在位置）
    Set st = Application.Session.DefaultStore
    ' 获取规则集合
    Set myRules = st.GetRules

    ' 遍历所有规则
    For Each rl In myRules
        ' 判断是否为收件箱规则
              If rl.RuleType = olRuleReceive And rl.IsLocalRule = True Then
            ' 如果是，执行规则
            rl.Execute ShowProgress:=True
            count = count + 1
            ruleList = ruleList & vbCrLf & rl.Name
        End If
    Next

    ' 告知用户执行结果
    ruleList = "以下收件箱规则已执行：" & vbCrLf & ruleList
    MsgBox ruleList, vbInformation, "宏：RunAllInboxRules"

    Set rl = Nothing
    Set st = Nothing
    Set myRules = Nothing
End Sub

一、实现规则自动触发（针对共享收件箱） #

共享收件箱的规则无法自动触发，核心原因是默认规则引擎仅监听默认收件箱的新邮件。我们可以通过Outlook的NewMailEx事件监听所有新到达的邮件（包括共享收件箱），手动匹配规则条件并执行操作，或者直接调用目标规则。

步骤1：配置NewMailEx事件处理代码 #

打开Outlook VBA编辑器（按Alt+F11），双击左侧的ThisOutlookSession，粘贴以下代码：

' 声明API函数用于强制弹窗前置
Private Declare PtrSafe Function SetForegroundWindow Lib "user32.dll" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    Dim objNS As Outlook.NameSpace
    Dim objMail As Outlook.MailItem
    Dim arrEntryIDs() As String
    Dim i As Integer
    Dim targetFolder As Outlook.Folder
    Dim sharedInbox As Outlook.Folder
    
    Set objNS = Application.GetNamespace("MAPI")
    arrEntryIDs = Split(EntryIDCollection, ",")
    
    ' 获取共享收件箱"AES Sales"的收件箱文件夹
    On Error Resume Next
    Set sharedInbox = objNS.Folders("AES Sales").Folders("收件箱")
    On Error GoTo 0
    
    If sharedInbox Is Nothing Then
        MsgBox "未找到共享收件箱'AES Sales'", vbExclamation
        Exit Sub
    End If
    
    ' 获取目标文件夹"Job Tickets"（假设位于共享收件箱根目录下）
    On Error Resume Next
    Set targetFolder = sharedInbox.Parent.Folders("Job Tickets")
    On Error GoTo 0
    
    If targetFolder Is Nothing Then
        MsgBox "未找到文件夹'Job Tickets'", vbExclamation
        Exit Sub
    End If
    
    ' 遍历所有新到达的邮件
    For i = 0 To UBound(arrEntryIDs)
        Set objMail = objNS.GetItemFromID(arrEntryIDs(i))
        
        ' 判断邮件是否来自目标共享收件箱，且主题匹配规则
        If objMail.Parent = sharedInbox Then
            If objMail.Subject Like "*Fitness Club - FF*" Or objMail.Subject Like "*Fitness First FM*" Then
                ' 执行规则操作：移动邮件+标记颜色类别
                objMail.Move targetFolder
                objMail.Categories = "绿色, 灰色"
                objMail.Save
                
                ' 触发前台提示弹窗
                ShowForegroundMsgBox "新邮件已自动处理：" & vbCrLf & objMail.Subject, "共享收件箱通知"
            End If
        End If
    Next i
    
    ' 释放对象
    Set objMail = Nothing
    Set objNS = Nothing
    Set sharedInbox = Nothing
    Set targetFolder = Nothing
End Sub

' 自定义前台弹窗函数
Private Sub ShowForegroundMsgBox(msg As String, title As String)
    ' 先弹出普通MsgBox
    MsgBox msg, vbInformation, title
    ' 找到弹窗窗口并强制前置
    Dim hwnd As LongPtr
    hwnd = FindWindow("#32770", title)
    If hwnd <> 0 Then
        SetForegroundWindow hwnd
    End If
End Sub

可选：调用已创建的规则执行 #

如果想直接调用你已配置的规则，可将上面代码中的「执行规则操作」部分替换为以下代码：

' 调用指定规则执行
Dim st As Outlook.Store
Dim myRules As Outlook.Rules
Dim rl As Outlook.Rule
Set st = objNS.DefaultStore
Set myRules = st.GetRules
For Each rl In myRules
    ' 替换为你创建的规则名称
    If rl.Name = "你的规则名称" Then
        rl.Execute ShowProgress:=False, Folder:=sharedInbox
        Exit For
    End If
Next

二、确保弹窗在前台显示 #

如果上述API调用方式无效，可改用WScript弹窗，它默认会强制在所有应用前台显示：

Private Sub ShowForegroundMsgBox(msg As String, title As String)
    ' vbSystemModal参数确保弹窗获得焦点
    CreateObject("WScript.Shell").Popup msg, 0, title, vbInformation + vbSystemModal
End Sub

三、启用宏 #

1. 保存代码后，关闭并重新打开Outlook；
2. 调整宏安全设置：点击「文件」→「选项」→「信任中心」→「信任中心设置」→「宏设置」，选择「启用所有宏」或「启用签署的宏」；
3. 测试：发送一封主题包含Fitness Club - FF的邮件到共享收件箱，检查是否自动移动邮件并弹出前台提示。

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