与excel列表中的域名相匹配的Outlook宏

Question

我需要一个宏，可以匹配的电子邮件id的域名从电子邮件列表(最好是从excel)和抄送，如果任何电子邮件地址不匹配，它应该抛出一个弹出窗口，询问用户是否要继续，如果是，那么邮件应该被发送，因为它的电子邮件id应该添加在密件抄送。

请找到示例代码，它的工作，但我也想比较域名作为一个子字符串的主题。

例如:如果主题行是"ABC Report- Company1- Jan-2“并且它被发送到a1@company1.com，a2@compay2.com，那么它应该提示a2@company2.com是一封未经授权的电子邮件，并询问用户是否仍然想继续，如果是，它应该复制密件抄送中的admin@mycompany.com并将邮件延迟5分钟。

            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
            Dim Address As String
            Dim lLen
            Dim strSubject As String

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

            strSubject = Item.Subject
            If strSubject Like "*ACB Report*" Or strSubject Like "*XYZ Report*" Then
               

            Set recips = Item.Recipients
            For Each recip In recips
            Set pa = recip.PropertyAccessor

             Address = LCase(pa.GetProperty(PR_SMTP_ADDRESS))
            lLen = Len(Address) - InStrRev(Address, "@")

            Select Case Right(Address, lLen)
                Case "cdolive.com", "gmail.com", "slipstick.com", "outlookmvp.com"
                    
                Case Else ' remove case else line to be warned when sending to the addresses
                 strMsg = strMsg & " " & Address & vbNewLine
            End Select
            Next

            If strMsg <> "" Then
            prompt = "This email will be sent outside of the company to:" & vbNewLine & strMsg & vbNewLine & "Please check recipient address." & vbNewLine & vbNewLine & "Do you still wish to send?"
            If MsgBox(prompt, vbYesNo + vbExclamation + vbMsgBoxSetForeground, "Check Address") = vbNo Then
            Cancel = True
            End If
            End If
            End If
            End Sub

Answer 1

电子邮件地址的倒数第二部分是第二级域(2LD)。这似乎是在查找与主题公司不同的Recipient2LD。

主题似乎是用户自由形式的输入，我不知道如何从主题行中解析出SubjectCompany，但如果可以，那么可以在EndSelect之后和Next之前添加此主题。

    Dim RecipDomainParts() As String 
    RecipDomainParts = Split(Right(Address, lLen), ".") 
    Dim Recip2LD As String  ' Recipient Second Level Domain
    Recip2LD = DomainParts(UBound(DomainParts) - 1)
    ' I have no idea how to parse the SubjectCompany out of the Subject line
    If Recip2LD <> SubjectCompany Then
        strMsg = strMsg & " " & Address & vbNewLine
    End If

->>added 9/2/18

您需要自己确定流程的大致轮廓:是为每个问题(列表或主题)的每个收件人提供一条错误消息，还是为每个收件人合并一条消息，同时处理每个收件人，或者在所有收件人的末尾将每个msg附加到一条消息中……然后按照你的大纲去做。首先改进大纲，然后编写与之匹配的代码。

在修改大纲后，为"Recip_in_List“创建一个sub，并为"RecipDomain_in_Subject”创建一个sub，这可能是很好的做法。

密件抄送可能不应该被跳过，因为用户可能会尝试将电子邮件放在那里。您的xyz@qwerty.com应该在列表中。

变量SendMail不能设置为True，因为它会清除在以前的收件人上设置的False。通过执行Exit Sub when vbNo，可以消除此布尔值。

Set Delay = 0min
For each Recip 

    If Recip not in List
        Popup to user
        If vbNo then Cancel=True and exit without send
        Else add BCC of xyz@qwerty.com if not there
        endif
    endif

    If RecipDomain not in Subject
        Popup to user
        If vbNo then Cancel=True and exit without send
        Else add BCC of admin@qwerty.com if not there
             set Delay = 5min
        endif
    endif

Next Recip
SEND with Delay

Answer 2

            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
            Dim Address As String
            Dim lLen
            Dim strSubject As String

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

            strSubject = Item.subject
            If strSubject Like "*ABC Report*" Or strSubject Like "*XYZ Report*" Then


            Set recips = Item.Recipients
            For Each recip In recips

             If recip.Type <> olBCC Then


                 Set pa = recip.PropertyAccessor

                 Address = LCase(pa.GetProperty(PR_SMTP_ADDRESS))


                 'rlen = Len(Address) - InStrRev(Address, "@")
                 'If strSubject Like "*rlen*" Then

                 lLen = Len(Address) - InStrRev(Address, "@")

                 'Select Case Left(Address, rlen)
                    'Case "acceture", "slipstick"
                    'Case Else
                    'strMsg = strMsg & " " & Address & vbNewLine
                    'End Select
                    'Next

                Dim SendMail As Boolean
                 Select Case Right(Address, lLen)
                    Case "cdolive.com", "slipstick.com", "outlookmvp.com", "accenture.com"
                        ' "select case" is doing nothing in this case
                        SendMail = True
                    Case Else ' remove case else line to be warned when sending to the addresses
                        strMsg = strMsg & " " & Address & vbNewLine
                 End Select


                    If strMsg <> "" And Not SubjectContainsEmailDomain(strSubject, Address) Then
                        prompt = "The system has detected that you are sending this email to some unauthorized user:" & vbNewLine & strMsg & vbNewLine & "Please check recipient address." & vbNewLine & vbNewLine & "Do you still wish to send?"
                        If MsgBox(prompt, vbYesNo + vbExclamation + vbMsgBoxSetForeground, "Check Address") = vbNo Then
                            Cancel = True
                        Else
                            ' add BCC
                            Dim objRecip As Recipient

                            Set objRecip = Item.Recipients.Add("myid@gmail.com")
                            objRecip.Type = olBCC
                            objRecip.Resolve
                            'MailItem.DeferredDeliveryTime = DateAdd("n", 90, Now)
                        End If
                    End If

                    ' Cancel if not in "cdolive.com", "slipstick.com", "outlookmvp.com"
                    If Not SendMail Then Cancel = True
                    MsgBox "The entered email address(s) are not aliged to you" & vbNewLine & "Please add the domain name in the code"
                  'End If
                'End If
                End If
            Next
            Last:
            End If
            End If
            End If
            End Sub



            Function GetDomain(emailAddress As String) As String

                Dim arr As Variant

                arr = Split(emailAddress, "@")

                GetDomain = Left(arr(1), InStrRev(arr(1), ".") - 1)

            End Function

            Function SubjectContainsEmailDomain(subject As String, email As String) As Boolean

                Dim domain As String
                domain = GetDomain(email)
                Dim index As Integer


                SubjectContainsEmailDomain = InStr(LCase(subject), LCase(domain))


            End Function