Vba 向Outlook中的外部域发送电子邮件之前发出警告

如果您要向外部域发送电子邮件，如何让Outlook发出警告

每天发送大量电子邮件总是可能错误地将电子邮件发送给错误的人。当他们是客户或公司以外的人时，这尤其是一个问题

使用

Alt+Enter

在为我键入电子邮件后快速发送电子邮件通常是原因，因为我没有彻底检查收件人

我发现了许多不太好的实现，所以我想在下面分享我的实现…

将以下代码添加到Outlook中的

应用程序\u ItemSend

事件中&将域更改为您自己的域

将

宏安全性

更改为（所有宏的通知或启用所有宏）

如果您的

收件人

、

抄送

或

密件抄送

地址不在您的域中（如下面的

@mycompany.com.au

），则在发送前会向您发出警告

---

感谢ojhhawkins提供上述代码-非常有用。我做了一个简单的迭代，在MsgBox文本中包含一个外部电子邮件地址列表

警告-我注意到，当您在其他程序（如Excel、Adobe Reader等）中使用“作为电子邮件发送”附件时，警告不会出现。正如所指出的：

回复：在其他节目中作为电子邮件附件发送。在outlookcode.com/d/code/setsavefolder.htm的“注意事项”中描述“……不适用于使用Office程序中的“发送”命令或Windows资源管理器或其他程序中的类似命令创建的邮件。这些命令调用简单MAPI，从而绕过Outlook功能。”

私有子应用程序\u ItemSend（ByVal项作为对象，取消作为布尔值）
将收件人设置为Outlook.Recipients
将recip设置为Outlook.Recipient
将pa设置为Outlook.PropertyAccessor
将提示变暗为字符串
作为字符串的Dim strMsg
常量PR_SMTP_地址作为字符串=”http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
设置recips=Item.Recipients
对于recips中的每个recips
设置pa=recip.PropertyAccessor
如果InStr（LCase（pa.GetProperty（PR_SMTP_地址）），“@example.com”）=0，则
strMsg=strMsg&&pa.GetProperty（PR\u SMTP\u地址）&vbNewLine
如果结束
下一个
如果strMsg“”则
prompt=“此电子邮件将在example.com之外发送到：”&vbNewLine&strMsg&“是否继续？”
如果MsgBox（提示，vbYesNo+VBEQUOTION+vbMsgBoxSetForeground，“检查地址”）=vbNo，则
取消=真
如果结束
如果结束
端接头

要将此代码实际添加到Outlook应用程序中，请执行以下操作：

• 如果在功能区栏中看不到“开发人员”选项卡，请转到“文件/选项”，在左侧选择“自定义功能区”，然后在右侧勾选“开发人员”
• 从“开发人员”选项卡中选择Visual Basic
• 展开Project1、Microsoft Outlook对象，然后双击此Outlook会话（左上角）
• 将上面的代码粘贴到模块中
• 将复制的代码中的“example.com”替换到域中
• 关闭VBA编辑器并保存对模块的更改
• 在“开发人员”选项卡上，单击“宏安全性”，并将级别更改为“所有宏的通知”或更低级别
• 重新启动Outlook。（否则，上述代码将不会初始化。）

---

我找到了两个Outlook加载项，如果您不想使用VBA，它们也可以执行相同的操作

• 及

---

除包含外部域条目的通讯组列表（也不接收“隐藏GAL”的邮件联系人）外，此功能适用于大多数情况。Re：在其他程序中作为电子邮件附件发送。此处的注释中描述了“…不适用于使用Office程序中的文件|发送命令或Windows资源管理器或其他程序中的类似命令创建的邮件。这些命令调用简单MAPI，绕过Outlook功能。”在几乎犯了职业调整错误后到达此处。感谢您列出了非VBA开发人员应该做什么。希望我不会再犯那个错误了！网站“”已不存在。我该怎么做？

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    Dim recips As Outlook.Recipients
    Dim recip As Outlook.Recipient
    Dim pa As Outlook.PropertyAccessor
    Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
    Set recips = Item.Recipients
    For Each recip In recips
        Set pa = recip.PropertyAccessor
        If InStr(LCase(pa.GetProperty(PR_SMTP_ADDRESS)), "@mycompany.com.au") = 0 Then
            If MsgBox("Send mail to external domain?", vbYesNo + vbQuestion + vbMsgBoxSetForeground, "Check Address") = vbNo Then
                Cancel = True
                Exit Sub
            Else
                Exit Sub
            End If
        End If
    Next
End Sub

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    Dim recips As Outlook.Recipients
    Dim recip As Outlook.Recipient
    Dim pa As Outlook.PropertyAccessor
    Dim prompt As String
    Dim strMsg As String

    Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"

    Set recips = Item.Recipients
    For Each recip In recips
        Set pa = recip.PropertyAccessor
        If InStr(LCase(pa.GetProperty(PR_SMTP_ADDRESS)), "@example.com") = 0 Then
            strMsg = strMsg & "   " & pa.GetProperty(PR_SMTP_ADDRESS) & vbNewLine
        End If
    Next

    If strMsg <> "" Then
        prompt = "This email will be sent outside of example.com to:" & vbNewLine & strMsg & "Do you want to proceed?"
        If MsgBox(prompt, vbYesNo + vbExclamation + vbMsgBoxSetForeground, "Check Address") = vbNo Then
            Cancel = True
        End If
    End If
End Sub