Outlook宏设置需求：向指定150人以外收件人发件前弹出提示

没问题！完全可以通过Outlook VBA宏实现这个需求——我经常帮用户配置这类收件人校验规则，亲测在Outlook 2016/2019/365上都能稳定运行。下面是具体的实现步骤和代码：

你可以选两种方式存储名单，看哪个更适合你：

• 方式1：文本文件（推荐，方便更新）：新建一个纯文本文件（比如命名为AllowedRecipients.txt），每行写一个邮箱地址，把它存到固定路径（比如C:\OutlookTools\，记得自己创建这个文件夹）。
• 方式2：直接写在代码里：如果名单几乎不会变动，也可以直接把邮箱地址写进代码的数组里，省得读文件。

1. 打开Outlook，按下Alt + F11打开VBA编辑器。
2. 在左侧的「项目」面板里，找到你的Outlook项目（一般是VBAProject.OTM），右键点击它 → 插入 → 模块。
3. 在新弹出的代码窗口里，根据你选的名单方式，粘贴对应的代码：

代码版本1：读取文本文件里的名单 #

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    Dim allowedRecipients As Collection
    Dim recipient As Outlook.Recipient
    Dim emailAddr As String
    Dim filePath As String
    Dim fileNum As Integer
    Dim lineText As String
    Dim isInvalid As Boolean
    Dim invalidList As String
    
    ' 初始化变量
    Set allowedRecipients = New Collection
    filePath = "C:\OutlookTools\AllowedRecipients.txt" ' 替换成你的文本文件路径
    isInvalid = False
    invalidList = ""
    
    ' 读取文本文件里的允许邮箱
    On Error Resume Next
    fileNum = FreeFile()
    Open filePath For Input As #fileNum
    Do While Not EOF(fileNum)
        Line Input #fileNum, lineText
        If Trim(lineText) <> "" Then
            ' 转成小写，避免大小写匹配问题
            allowedRecipients.Add LCase(Trim(lineText)), Key:=LCase(Trim(lineText))
        End If
    Loop
    Close #fileNum
    On Error GoTo 0
    
    ' 检查所有收件人（To/Cc/Bcc）
    For Each recipient In Item.Recipients
        emailAddr = LCase(recipient.Address)
        ' 处理Exchange地址的情况（转成SMTP格式）
        If recipient.AddressEntry.Type = "EX" Then
            emailAddr = LCase(recipient.AddressEntry.GetExchangeUser.PrimarySmtpAddress)
        End If
        
        ' 检查是否在允许名单里
        On Error Resume Next
        allowedRecipients(emailAddr)
        If Err.Number <> 0 Then
            isInvalid = True
            invalidList = invalidList & vbCrLf & "- " & emailAddr
        End If
        On Error GoTo 0
    Next recipient
    
    ' 如果有无效收件人，弹出提示
    If isInvalid Then
        Dim response As Integer
        response = MsgBox("注意：以下收件人不在允许列表中：" & invalidList & vbCrLf & vbCrLf & "是否继续发送？", vbYesNo + vbExclamation, "收件人校验提示")
        If response = vbNo Then
            Cancel = True ' 取消发送
        End If
    End If
End Sub

代码版本2：直接用数组存储名单 #

如果不想用文本文件，把上面的代码替换成这个版本，把你的150个邮箱填到allowedEmails数组里就行：

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    Dim allowedEmails As Variant
    Dim allowedRecipients As Collection
    Dim recipient As Outlook.Recipient
    Dim emailAddr As String
    Dim isInvalid As Boolean
    Dim invalidList As String
    Dim i As Integer
    
    ' 在这里填入你的允许收件人邮箱
    allowedEmails = Array( _
        "user1@example.com", _
        "user2@example.com", _
        "user3@example.com" _
        ' 继续添加剩下的邮箱...
    )
    
    ' 初始化集合
    Set allowedRecipients = New Collection
    isInvalid = False
    invalidList = ""
    
    ' 把数组转成集合，方便查找
    For i = LBound(allowedEmails) To UBound(allowedEmails)
        allowedRecipients.Add LCase(Trim(allowedEmails(i))), Key:=LCase(Trim(allowedEmails(i)))
    Next i
    
    ' 以下检查逻辑和版本1完全一致
    For Each recipient In Item.Recipients
        emailAddr = LCase(recipient.Address)
        If recipient.AddressEntry.Type = "EX" Then
            emailAddr = LCase(recipient.AddressEntry.GetExchangeUser.PrimarySmtpAddress)
        End If
        
        On Error Resume Next
        allowedRecipients(emailAddr)
        If Err.Number <> 0 Then
            isInvalid = True
            invalidList = invalidList & vbCrLf & "- " & emailAddr
        End If
        On Error GoTo 0
    Next recipient
    
    If isInvalid Then
        Dim response As Integer
        response = MsgBox("注意：以下收件人不在允许列表中：" & invalidList & vbCrLf & vbCrLf & "是否继续发送？", vbYesNo + vbExclamation, "收件人校验提示")
        If response = vbNo Then
            Cancel = True
        End If
    End If
End Sub

1. 保存VBA代码，关闭编辑器。
2. 打开Outlook的「文件」→「选项」→「信任中心」→「信任中心设置」→「宏设置」，选择「启用所有宏」（如果担心安全，可以选「签署的宏」，然后给自己的宏签名，步骤稍微复杂一点，但更安全）。
3. 重启Outlook，写一封测试邮件，添加一个不在名单里的邮箱，点击发送——这时应该会弹出提示框，告诉你有无效收件人，让你选择继续还是取消发送。

• 如果你的名单经常变动，强烈推荐用文本文件版本，改名单不用动代码。
• 代码里已经处理了Exchange内部地址的情况（会自动转成SMTP格式），所以内网邮箱也能正常校验。
• 可以定期备份你的VBAProject.OTM文件，防止宏丢失（文件路径一般是C:\Users\[你的用户名]\AppData\Roaming\Microsoft\Outlook\）。

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