电子邮件收件人姓名验证

Question

Outlook 中有一个工具可以在发件人单击“发送”按钮时通知他们可能丢失的附件。该工具似乎会在电子邮件正文中搜索“附件”等关键字，然后检查电子邮件是否附加了任何内容。如果没有，则弹出通知。

我正在寻找类似但更高级的东西。当我的电子邮件正文既不包含收件人的名字也不包含姓氏时，我希望出现类似的通知弹出窗口。

编辑/更新

基于 FaneDuru 的回答，我最终创建了自己的 VBA 代码来解决这个问题。 请考虑关闭此问题。

注意：我的代码搜索每个收件人的名字、中间名或姓氏，但只搜索正文的前两行电子邮件。如果这些搜索中的任何一个成功（即如果在前两行找到该名称），则检查成功并且可以发送电子邮件，否则通知发件人。

当收件人的电子邮件地址不在发件人的地址簿中时，程序会执行其他类似的操作，这些操作在代码中很容易看出。

请随时提出改进建议。

Option Explicit

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
   If TypeName(Item) = "MailItem" Then
       Dim myMail As MailItem, recip As Recipient, strNoRef As String, msg As VbMsgBoxResult, msge As VbMsgBoxResult, noEntry As String
       Dim i As Integer
       Dim j As Integer
       Dim Lines() As String
       Dim fLines As String
       i = 0
       j = 0
       Set myMail = Item
       Lines = Split(myMail.Body, vbCrLf, 4)
       fLines = Lines(0) & Lines(1) & Lines(2)
       For Each recip In myMail.Recipients
           If recip.Address <> recip.AddressEntry Then
               i = i + 1
               If Not NameExists(recip.AddressEntry, fLines) Then
                   j = j + 1
                   strNoRef = strNoRef & recip.AddressEntry & vbCrLf
               End If
           End If
       Next

       For Each recip In myMail.Recipients
           If Not recip.Address <> recip.AddressEntry Then
               noEntry = noEntry & recip.AddressEntry & vbCrLf
           End If
       Next

       If j = i And noEntry = "" Then
           msg = MsgBox("This mail does not contain a reference to anyone of the following:" & vbCrLf & _
           vbCrLf & strNoRef & vbCrLf & _
           "To send the mail anyway, please press ""Yes"".", vbYesNo, "Send the mail?")
           If msg <> vbYes Then Cancel = True
       End If

       If j = i And noEntry <> "" Then
           msg = MsgBox("This mail does not contain a reference to anyone of the following:" & vbCrLf & _
           vbCrLf & strNoRef & vbCrLf & _
           "And the following recipients are not in the address book:" & vbCrLf & _
           vbCrLf & noEntry & vbCrLf & _
           "To send the mail anyway, please press ""Yes"".", vbYesNo, "Send the mail?")
           If msg <> vbYes Then Cancel = True
       End If
                                
       If noEntry <> "" And j < i Then
           msge = MsgBox("The following recipients are not in the address book:" & vbCrLf & _
           vbCrLf & noEntry & vbCrLf & "So, the email was not sent." & vbCrLf & _
           "To send it, please press ""Yes"".", vbYesNo, "Send the mail?")
           If msge <> vbYes Then Cancel = True
       End If
       
       If noEntry = "" And j < i Then
           Cancel = False
       End If
       
   End If
End Sub

Function NameExists(strName As String, strBody As String) As Boolean
   Dim arrName, El
   arrName = Split(strName, " ")
   For Each El In arrName
        If InStr(1, strBody, El, vbBinaryCompare) > 0 Then
            NameExists = True: Exit Function
        End If
   Next El
End Function

Answer 1

为了达到您尝试解释的效果，请按以下方式进行：

更改 Outlook 安全设置，使其以 Macro Enabled:

File - Options - Trust Center - Trust Center Settings... - Macro Settings 并选择 Notifications for all Macros 或 Enable All Macros (not recommended...。按'OK'，当然...

关闭并重新打开 Outlook，选择 Enable Macros!

按 F11 以访问 VBE (Visual Basic for Applications) window。在其左侧窗格中，您将看到 Project1 (VBAProject.OTM).

展开 Microsoft Outlook Objects 并双击 ThisOutlookSession。

在开头window（右边），请复制下一段代码：

Option Explicit

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
   If TypeName(Item) = "MailItem" Then
       Dim myMail As MailItem, recip As Recipient, strNoRef As String, msg As VbMsgBoxResult, noEntry As String
       Set myMail = Item                          'just to benefit of intellisense suggestions...
        For Each recip In myMail.Recipients   'iterate between mail recipients
            If recip.Address <> recip.AddressEntry Then 'if the address has a name (not only xxx@domain.com):
                If Not NameExists(recip.AddressEntry, myMail.Body) Then 'check if one of its names (first or last) exists
                    strNoRef = strNoRef & recip.AddressEntry & vbCrLf      'if not, build a string to be used in the message
                End If
            Else
                noEntry = noEntry & recip.AddressEntry & vbCrLf
            End If
        Next
        
        If noEntry <> "" Then
            MsgBox "The following recipients are not in the address book:" & vbCrLf & _
                   vbCrLf & noEntry
        End If
        If strNoRef <> "" Then
            msg = MsgBox("The mail you try sending does not contain a reference to" & vbCrLf & _
                vbCrLf & strNoRef & vbCrLf & "and it cannot be sent..." & vbCrLf & _
                "To send it as it is, please press ""Yes"".", vbYesNo, "Send the mail?")
            If msg <> vbYes Then Cancel = True 'if not pressing "Yes", the sending will be cancelled
        End If
    End If
End Sub

Function NameExists(strName As String, strBody As String) As Boolean
   Dim arrName, El
   arrName = Split(strName, " ")
   For Each El In arrName
        If InStr(1, strBody, El, vbBinaryCompare) > 0 Then
            NameExists = True: Exit Function
        End If
   Next El
End Function

最好在 VBE Standard 工具栏上按 Save。我的东西 Ctrl + S 也可以工作...

尝试使用邮件并发送一些反馈...

电子邮件收件人姓名验证

Email recipient name verification

outlook

vba

outlook-addin