自定义outlook发送邮件时的弹出check窗口

### 自定义Outlook发送邮件时的弹出Check窗口 #### 概述 在日常工作中，Microsoft Outlook 是一种常用的电子邮件客户端工具。为了确保邮件发送至正确的收件人，并避免潜在的人为错误，我们可以利用宏（macro）功能来自定义一个检查窗口，在用户发送邮件前对收件人进行确认。 #### 实现步骤 1. **开启宏编辑器**：打开Outlook，通过`Tools -> Macro -> Visual Basic Editor`进入宏编辑器。 2. **复制粘贴代码**：将以下提供的VBA代码复制并粘贴到新建的模块中。 3. **重启Outlook**：保存更改后重启Outlook，此时自定义的检查窗口功能即可生效。 #### VBA代码详解 ##### 宏主体代码 ```vba Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean) Dim objRecip As Recipient Dim objContact As ContactItem Dim strExternal As String If Item.MessageClass Like "IPM.TaskRequest*" Then Set Item = Item.GetAssociatedTask(False) End If strExternal = "" For Each objRecip In Item.Recipients Set objContact = FindContactByAddress(objRecip.Address) If objContact Is Nothing Then If LCase(objRecip.Address) Like "/o=*" Then strExternal = strExternal & "[HPCompany]: " & objRecip.Name & vbCr Else strExternal = strExternal & "[OtherCompany]: " & objRecip.Name & vbCr End If Else strExternal = strExternal & "[HPCompany]: " & objRecip.Name & vbCr End If Next If strExternal <> "" Then MSGText = "Title: [" & Item.Subject & "]" & vbCr & _ "The following are mail addresses. Are they OK?" & _ vbLf & "Receiver: " & vbCr & strExternal If MsgBox(MSGText, vbYesNo, "Name Checking") = vbNo Then Cancel = True End If End If End Sub ``` - **触发条件**：当用户尝试发送邮件时，该宏会被触发。 - **逻辑流程**： - 检查邮件类型是否为任务请求（`IPM.TaskRequest*`），如果是，则获取与之关联的任务。 - 遍历邮件中的所有收件人，对于每个收件人执行以下操作： - 使用`FindContactByAddress`函数查找Outlook联系人列表中是否存在对应的联系人记录。 - 如果不存在对应联系人记录，则根据地址格式判断其是否属于公司内部邮箱地址（如包含`/o=*`则视为公司内部邮箱）；否则，默认为外部邮箱地址。 - 根据收件人的归属（内部或外部），将收件人名称添加到`strExternal`变量中。 - 如果存在任何非公司内部的收件人，则显示一个包含收件人列表的弹出框，并询问用户是否确认发送。 - 如果用户选择“否”，则取消邮件发送（设置`Cancel`参数为`True`）。 ##### 辅助函数：查找联系人 ```vba Private Function FindContactByAddress(strAddress As String) Dim objContacts Dim objContact Set objContacts = Application.Session.GetDefaultFolder(olFolderContacts) Set objContact = objContacts.Items.Find("[Email1Address]='" & strAddress & _ "' or [Email2Address]='" & strAddress & _ "' or [Email3Address]='" & strAddress & "'") Set FindContactByAddress = objContact End Function ``` - **功能**：根据邮箱地址查询Outlook联系人列表中的联系人记录。 - **实现方法**：遍历默认联系人文件夹中的所有联系人，查找匹配的邮箱地址。 - 支持查询联系人的三个不同邮箱字段：`Email1Address`、`Email2Address`和`Email3Address`。 - 如果找到匹配项，则返回对应的联系人对象；否则，返回`Nothing`。 #### 结论 通过上述VBA宏的实现，可以在Outlook中增加一项实用的功能，即在发送邮件之前自动检查收件人是否正确，并提示用户确认，从而有效避免了因误发邮件导致的信息泄露或其他问题。此功能尤其适用于需要频繁处理敏感信息的企业环境，有助于提高工作效率和数据安全性。