我需要一个宏，它可以从电子邮件列表（最好是从excel）匹配TO和CC中的电子邮件ID的域名，如果任何电子邮件地址不匹配，它应该弹出一个询问用户是否需要的弹出窗口继续，如果是，则邮件应按原样发送，并在BCC中添加电子邮件ID。
请查找示例代码，它可以工作，但我也想将域名作为主题中的子字符串进行比较。
例如：如果主题行是“ABC报告 - 公司1 - 1月2日，它被发送到[email protected]，a2 @ compay2.com然后它应该提示[email protected]是未经授权的电子邮件并询问如果仍然是用户想要继续，如果是，它应该在BCC中复制[email protected]并将邮件延迟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
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("[email protected]")
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
电子邮件地址的最后一部分是二级域名（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”创建sub并为“RecipDomain_in_Subject”创建子项可能会很好。
可能不应该跳过BCC，因为用户可能会尝试在那里发送电子邮件。您的[email protected]应该在列表中。
变量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 [email protected] 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 [email protected] if not there
set Delay = 5min
endif
endif
Next Recip
SEND with Delay