Conditionally Prevent Outlook from Sending Email Based on From and Recipient Addresses

Question

I have multiple mail accounts setup in Outlook 2007 (e.g., johndoe@domainA.com, johndoe@domainB.com, etc.). Occasionally, usually as the result of the Auto Complete feature, I will mistakenly send email from johndoe@domainA.com to a recipient that should only be receiving mail from johndoe@domainB.com).

These restrictions between from (my selected mail account) and recipient (To or CC) email addresses can generally be defined by domain name.

For example, johndoe@domainA.com should not send to recipient-domainX.com & recipient-domainY.com. And johndoe@domainB.com should not send to recipient-domain1.com & recipient-domain2.com.

So it would be fine to explicitly define or "hardcode" these domain restrictions per mail account in a VBA script or text file.

So how, using VBA or other means, can I implement a check of the email addresses, to prevent an email from being sent if one of these restrictions is being violated.

Open to other more elegant solutions as well.

Thanks.

score 3 · Answer 1 · edited Dec 17 '11 at 18:27

This lets you screen emails out by address. I can't claim much credit for this, it's largely several different codes posted online merged into one. Regardless, it works solid and should get you half way to where you want to be. This is used in our company to send all externally sent emails into a public folder HR reviews.

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    If Item.Class <> olMail Then Exit Sub
    Dim objMail As MailItem
    Set objMail = Item
    Dim NotInternal As Boolean
    NotInternal = False
    Dim objRecip As Recipient
    Dim objTo As Object
    Dim str As String
    Dim res As Integer
    Dim strBcc As String
    On Error Resume Next
    Const PidTagSmtpAddress As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
    Dim i As Integer
    Dim objRecipColl As Recipients
    Set objRecipColl = objMail.Recipients
    Dim objOneRecip As Recipient
    Dim objProp As PropertyAccessor
    For i = 1 To objRecipColl.Count Step 1
        Set objOneRecip = objRecipColl.Item(i)
        Set objProp = objOneRecip.PropertyAccessor
        str = objProp.GetProperty(PidTagSmtpAddress)
        If Len(str) >= 17 Then  'Len of email address screened.  
            If UCase(Right(str, 17)) <> "@COMPANYEMAIL.COM" Then NotInternal = True
        Else
            NotInternal = True
        End If
    Next
    If NotInternal = True Then
        strBcc = "HRExternalEmails@COMPANYEMAIL.com"
        Set objRecip = objMail.Recipients.Add(strBcc)
        objRecip.Type = olBCC
            If Not objRecip.Resolve Then
                strMsg = "Could not resolve the Bcc recipient. " & _
                         "Do you still want to send the message?"
                res = MsgBox(strMsg, vbYesNo + vbDefaultButton1, _
                        "Could Not Resolve Bcc Recipient")
                If res = vbNo Then
                    Cancel = True
                End If
            End If
    End If
    Set objRecipColl = Nothing
    Set objRecip = Nothing
    Set objOneRecip = Nothing
    Set objMail = Nothing
    Set objTo = Nothing
    Set oPA = Nothing
End Sub

score 1 · Answer 2 · answered Jul 12 '13 at 12:34

I've modified the code to be slightly easier to read, effectively the same code just a little neater.

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

If Item.Class <> olMail Then Exit Sub

Dim sCompanyDomain As String: sCompanyDomain = "companydomain.com"

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

On Error Resume Next
Dim oMail As MailItem: Set oMail = Item
Dim oRecipients As Recipients: Set oRecipients = oMail.Recipients
Dim bDisplayMsgBox As Boolean: bDisplayMsgBox = False

Dim sExternalAddresses As String
Dim oRecipient As Recipient

For Each oRecipient In oRecipients

    Dim oProperties As PropertyAccessor: Set oProperties = oRecipient.PropertyAccessor
    Dim smtpAddress As String: smtpAddress = oProperties.GetProperty(PidTagSmtpAddress)

    Debug.Print smtpAddress

    If (Len(smtpAddress) >= Len(sCompanyDomain)) Then

        If (Right(LCase(smtpAddress), Len(sCompanyDomain)) <> sCompanyDomain) Then

            ' external address found
            If (sExternalAddresses = "") Then

                sExternalAddresses = smtpAddress

            Else

                sExternalAddresses = sExternalAddresses & ", " & smtpAddress

            End If

            bDisplayMsgBox = True

        End If

    End If

Next

If (bDisplayMsgBox) Then

    Dim iAnswer As Integer
    iAnswer = MsgBox("You are about to send this email externally to " & sExternalAddresses & vbCr & vbCr & "Do you want to continue?", vbExclamation + vbYesNo, "External Email Check")

    If (iAnswer = vbNo) Then
        Cancel = True
    End If

End If

End Sub

Conditionally Prevent Outlook from Sending Email Based on From and Recipient Addresses

2 Answers2

Linked