Question

我需要一个宏，该宏可以匹配电子邮件列表中TO和CC中电子邮件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

->>添加了9/2/18

您需要确定自己的总体流程：在处理每个收件人时，是针对每个问题（列表或主题）向每个收件人显示错误消息，还是为一个收件人合并成一条消息？在每个收件人的末尾将每个msg合并为一封邮件...然后按照您的概述进行操作。首先完善轮廓，然后编写匹配的代码。

修改轮廓后，最好为“ Recip_in_List”创建子项，并为“ RecipDomain_in_Subject”创建子项。

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

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

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

Outlook宏以匹配Excel中列表中的域名

2 个答案: