在发送电子邮件之前验证外部收件人

Question

我正在寻找一个宏，运行时，用户试图发送电子邮件到外部域(to, Cc，密件)。它应该会弹出一个用户表单，用户需要在其中输入用逗号或分号分隔的所有不同收件人的域名。如果所有的域都匹配，则应该发送电子邮件，否则用户应该收到一个提示。

我找到了代码并尝试进行更改。

Public pass As Integer
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 a 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
Address = LCase(pa.GetProperty(PR_SMTP_ADDRESS))
lLen = Len(Address) - InStrRev(Address, "@")
Select Case Right(Address, lLen)
Case "abc.com", "abd.com" ', "efg.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?"
'MsgBox "You are sending email to external user(s) " & vbNewLine & "Please ask your lead for validation", vbInformation, "External User!"
UserForm3.Show
If UserForm3.Cancelled Then
Cancel = True
Else
Cancel = False
End If
End If
End Sub

用户表单代码:

Private IsCancelled As Boolean
Public Property Get Cancelled() As Boolean
Cancelled = IsCancelled
End Property
Private Sub Image5_Click()
If TextBox1.Value = "123456789" Then
MsgBox "Validation Successful!", vbInformation, "Success!"
Unload Me
Cancel = False
Else
MsgBox "Invalid Login details", vbCritical, "Invalid"
Cancel = True
End If
End Sub
Private Sub CancelButton_Click()
OnCancel
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = VbQueryClose.vbFormControlMenu Then
Cancel = True
OnCancel
End If
End Sub
Private Sub OnCancel()
IsCancelled = True
Unload Me
Me.Hide
End Sub

Answer 1

Re:例如:用户要发送电子邮件到[e-mail]，但错误地键入[e-mail]。所以用户会输入"abc"但是，它将与收件人的域不匹配，用户不应该能够发送电子邮件。

如果用户输入"abcd"在用户表单中?

是的，那是正确的!

---

如果您接受用户在用户表单中输入的任何内容，则版本1。
如果用户应该被以正常的方式对待，那么版本2。

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim recips As Recipients
Dim recip As Recipient
Dim pa As propertyAccessor
Dim prompt As String
Dim strMsg As String
Dim Address As String
Dim lLen As Long
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

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

Select Case Right(Address, lLen)

Case "abc.com", "abd.com" ', "efg.com"

Case Else
strMsg = strMsg & " " & Address & vbNewLine
End Select
Next

' version 1 - give the user control
If strMsg <> "" Then

prompt = "This email will be sent outside of the company to" & vbNewLine
prompt = prompt & " recipient(s) with domain that is not approved:" & vbNewLine & strMsg
prompt = prompt & vbNewLine & "Please check recipient address(es)."

prompt = prompt & vbNewLine & vbNewLine & "Do you still wish to send?"

If MsgBox(prompt, vbQuestion + vbYesNo + vbDefaultButton2, "Domain not listed!") = vbNo Then
Cancel = True
End If

End If

' version 2 - strictly forbidden if not on list
If strMsg <> "" Then
Cancel = True

prompt = "This email has recipient(s) with a domain that is not approved:" & vbNewLine & strMsg
prompt = prompt & vbNewLine & "Please change recipient address(es)."

prompt = prompt & vbNewLine & vbNewLine & "Send cancelled."

MsgBox prompt, vbCritical, "Domain not approved!"

End If
End Sub