Avoid Sending Mail from the Wrong Account

Introduction

Have Outlook configured with multiple acocunts? Your work account and several personal accounts? Ever accidently send a work email from your personal acccount? This bit of Outlook code will prompt you for those mistakes.

Background

I have found that I often end up sending work emails from my personal accounts that I have configured in Outlook. So VBA to the rescue.

Using the Code

Insert the following code in the ThisOutlookSession module. You can do this by showing the developerribbon on the menu. Then selecting the developer ribbon/ Visual Basic on the far left of the ribbon.

In the application section, insert the following code. You can open up 'ThisOutlookSession' which opens up the correct source code file. Make sure the application is selected on the upper left hand drop down box.

You need to make two changes in the code below in the bolded area. Replace the first bold with the account name you are sending from. Note you can find this out by setting a break point in the debugger on the 2^nd if statement and printing out the mail.SendUsingAccount when you send mail from your work account.

The 2^nd bolded section is the domain name of your companies email address. So if your company is ZYX and your email address is <a href="mailto:brady@ZYX.com">brady@ZYX.com</a>, then replace it with ZYX.

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
 Dim prompt As String
 Dim mail As Outlook.MailItem
 Dim r As VbMsgBoxResult
 Dim recips As Outlook.Recipients
 Dim recip As Outlook.Recipient
 Dim pa As Outlook.PropertyAccessor

If Item.Class = olMail Then
 
    Set mail = Item
    
    If mail.SendUsingAccount <> "myname@mycompanyemail.com" Then 
    
    Const PR_SMTP_ADDRESS As String = _
        "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
    Set recips = mail.Recipients
    For Each recip In recips
        Set pa = recip.PropertyAccessor
        Debug.Print recip.Name & " SMTP=" _
           & pa.GetProperty(PR_SMTP_ADDRESS)
         ' replace companyDomain with the name of your companies domain email name.  
         ' The part after the @
         If InStr(1, pa.GetProperty(PR_SMTP_ADDRESS), "companyDomain", vbTextCompare) > 0 Then
         
            r = MsgBox("Do you want to send to companyDomain from non companyDomain account?", vbYesNo)
            If r = vbNo Then
                Cancel = True
                Exit For
                
            End If
        End If
    Next
       
    End If
End If
    
End Sub