如何在通过 Outlook 发送邮件前检查收件人地址？

有时，在使用 Outlook 发送邮件时，您可能会不小心遗漏在收件人、抄送或密送栏中添加某些重要联系人。本文将为您介绍一种方法，帮助您在通过 Outlook 发送邮件前，检查是否已添加指定的邮箱地址。

使用 VBA 代码发送前检查地址

---

使用 VBA 代码发送前检查地址

这里为您提供两段代码，您可根据需求灵活选择使用。

1. 请按下 Alt + F11 组合键，即可打开 Microsoft Visual Basic for Applications 窗口。

2. 双击 ThisOutlookSession，在 Project 1 窗格中打开代码编辑器，然后将以下代码复制并粘贴到编辑器中。

VBA：发送前检查收件人地址是否在收件人栏中

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'UpdatebyExtendoffice20180523
Dim xAddressArr() As Variant
Dim xAddress As String
Dim xRecipient As Recipient
Dim xPrompt As String
Dim xYesNo As Integer
Dim xDictionary As Scripting.Dictionary
On Error Resume Next
Set xDictionary = New Scripting.Dictionary
xAddressArr = Array("example1@126.com", "example2@126.com", "example3@126.com")
For i = LBound(xAddressArr) To UBound(xAddressArr)
    xDictionary.Add xAddressArr(i), True
Next i
For Each xRecipient In Item.Recipients
    If xRecipient.Type = olTo Then
        If xDictionary.Exists(xRecipient.Address) Then xDictionary.Remove xRecipient.Address
    End If
Next
If xDictionary.Count = 0 Then GoTo L1
For i = 0 To xDictionary.Count - 1
    If xAddress = "" Then
        xAddress = xDictionary.Keys(i)
    Else
        xAddress = xAddress + "; " & xDictionary.Keys(i)
    End If
Next i
xPrompt = "You are not sending this to: " & xAddress & ". Are you sure you want to send the Mail?"
xYesNo = MsgBox(xPrompt, vbQuestion + vbYesNo, "Kutools for Outlook")
If xYesNo = vbNo Then Cancel = True
L1:
  Set xRecipient = Nothing
  Set xDictionary = Nothing
End Sub

在代码中，您可以将（“example 1@126.com”、“example 2@126.com”、“example 3@126.com”）替换为您实际需要的收件人地址。

3. 然后同样在 Microsoft Visual Basic for Applications 窗口中，点击工具 > 引用，在 References-Project 1 对话框中勾选 Microsoft Scripting Runtime 复选框。

4. 点击确定，即可保存代码。

现在，如果您在发送邮件时指定的收件人未出现在收件人栏，系统将弹出对话框提醒您是否继续发送该邮件。

上述代码仅会检查邮箱地址是否位于收件人栏。如需同时在收件人、抄送和密送栏中进行检查，请使用下方代码。

VBA：发送前检查收件人/抄送/密送栏地址

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'UpdatebyExtendoffice20180523
Dim xRecipients As Outlook.Recipients
Dim xRecipient As Outlook.Recipient
Dim xPos As Integer
Dim xYesNo As Integer
Dim xPrompt As String
Dim xAddress As String
On Error Resume Next
If Item.Class <> olMail Then Exit Sub
Set xRecipients = Item.Recipients
xAddress = "example1@gmail.com"
For Each xRecipient In xRecipients
    xPos = InStr(LCase(xRecipient.Address), xAddress)
    If xPos = 0 Then
        xPrompt = "You sending this to " & xAddress & ". Are you sure you want to send it?"
        xYesNo = MsgBox(xPrompt, vbYesNo + vbQuestion + 4096, "Kutools for Outlook")
        If xYesNo = vbNo Then Cancel = True
    End If
Next xRecipient
End Sub

无需勾选 Microsoft Scripting Runtime 复选框，直接保存代码即可生效。