Wednesday, March 19, 2008

Automatic Email Account Assignment in Outlook

NOTE: THIS HAS BEEN UPDATED TO WORK WITH OUTLOOK 2007

I use Google Apps to host my family's and my private company's email but I manage my email through Outlook 2003 (because I prefer to operate off-line and I need to synchronise with my Nokia N95 phone).

Google Mail is fantastic but the issue I had to grapple with relates to how email is pulled into Outlook. Email sent to warren@[personal] and warren@[business] ends up arriving in the one inbox and is automatically assigned to the default email account in Outlook ([business] in this case).

When I reply to an email I want it to be sent through the correct account so that the sender and reply addresses match the right context. I can do that manually using the Accounts button followed by the Send button but there is another (better) way using VBA.

First download and install the excellent Redemption COM Library written by Dmitry Streblechenko. This will expose the required properties of the Outlook object model without triggering the user confirmation dialog introduced by the Outlook Security Patch. It also provides access to many useful MAPI properties not available through the standard Outlook object model.

The following code is triggered whenever new mail arrives in Outlook. In essence, I look for certain phrases that indicate that the mail has been sent to my [personal] address and then change the mail account for that message to match. Subsequently, when I reply to that message, I don't need to choose which address to send it from as that has already been selected.

It works 95% of the time with misses probably due to timing issues and possible conflicts with Outlook rules. The NewMailEx event is perhaps not guaranteed to fire (despite what the documentation says) and so sometimes the account is left set to the incorrect one but I am happy enough with the result. The techniques employed here could be used for other new mail triggered actions.

First, create a new Class module in your Outlook VBA project called clsNewMailHandler

Option Explicit

Public WithEvents oApp As Outlook.Application
Const TC_BAINSWORLD_ACCOUNT = "bainsworld"


Private Sub Class_Terminate()
Set oApp = Nothing
End Sub


Private Sub oApp_NewMailEx(ByVal EntryIDCollection As String)

' This will be called whenever we receive new mail so
' process each item to determine if we should alter
' the account - do we need to worry about conflicts with Rules?

Dim astrEntryIDs() As String
Dim objItem As Object
Dim varEntryID As Variant

astrEntryIDs = Split(EntryIDCollection, ",")
For Each varEntryID In astrEntryIDs
Set objItem = oApp.Session.GetItemFromID(varEntryID)
If objItem.Class = olMail Then
' Only call this for MailItems - can be ReadReceipts
' too which are class olReport
Call SetEmailAccount(objItem)
End If
Next varEntryID
Set objItem = Nothing
End Sub


Private Sub SetEmailAccount(ByRef oItem As MailItem)

' This code will check if the item is of interest to
' us and if so will update the account property accordingly

' Check if this was sent to a 'bainsworld' address
If CheckMessageRecipient(oItem, TC_BAINSWORLD_ACCOUNT, False) Then
' Yes it was - change the account
Call SetMessageAccount(oItem, TC_BAINSWORLD_ACCOUNT, True)
End If
End Sub


Private Sub Class_Initialize()
Set oApp = Application
End Sub

Next create a new standard Module called basMailRoutines and import this code:

Option Explicit

Private Const PR_HEADERS = &H7D001E
Private Const PR_ACCOUNT = &H80F8001E


Public Function CheckMessageRecipient( _
ByRef oItem As MailItem, _
ByVal strMatch As String, _
Optional ByVal blnExact As Boolean = False) As Boolean

' Check if the supplied string matches the recipient
' of the email. We use the internet headers and check
' the first part of the string if we can. The match
' can be made exact or not

Const TC_HEADER_START As String = "Delivered-To:"
Const TC_HEADER_END As String = "Received:"

Dim strHeader As String
Dim intStart As Integer
Dim intEnd As Integer
Dim strRecipient As String

' First get the header and see if it makes sense
strHeader = GetInternetHeaders(oItem)
intStart = InStr(1, strHeader, TC_HEADER_START, vbTextCompare)
If intStart = 0 Then intStart = 1
intEnd = InStr(intStart, strHeader, vbCrLf & TC_HEADER_END, vbTextCompare)

If intEnd = 0 Then
' The headers are unreliable so just check the whole string
strRecipient = strHeader
Else
' Found headers so grab the recipient data
strRecipient = Trim$(Mid$(strHeader, intStart + Len(TC_HEADER_START), _
intEnd - (intStart + Len(TC_HEADER_START))))
End If

' Now undertake the check
If blnExact Then
CheckMessageRecipient = (strRecipient = strMatch)
Else
CheckMessageRecipient = (InStr(1, strRecipient, strMatch, vbTextCompare) > 0)
End If
End Function


Public Sub SetMessageAccount(ByRef oItem As MailItem, _
ByVal strAccount As String, _
Optional blnSave As Boolean = True)

Dim rMailItem As Redemption.RDOMail
Dim rSession As Redemption.RDOSession
Dim rAccount As Redemption.RDOAccount

' Use a RDO Session object to locate the account
' that we are interested in

Set rSession = New Redemption.RDOSession
rSession.MAPIOBJECT = Application.Session.MAPIOBJECT
Set rAccount = rSession.Accounts(strAccount)

' Now use the RDO Mail object to change the account
' to the one we require

Set rMailItem = rSession.GetMessageFromID(oItem.EntryID)
rMailItem.Account = rAccount
If blnSave Then
' They want us to force a save to the mail object
rMailItem.Subject = rMailItem.Subject
rMailItem.Save
End If
Set rMailItem = Nothing
Set rAccount = Nothing
Set rSession = Nothing
End Sub


Public Function GetInternetHeaders(ByRef oItem As MailItem) As String

Dim rUtils As Redemption.MAPIUtils

' Return the internet header of a message
Set rUtils = New Redemption.MAPIUtils
GetInternetHeaders = rUtils.HrGetOneProp(oItem.MAPIOBJECT, PR_HEADERS)
Set rUtils = Nothing
End Function

Finally, add the following code to the ThisOutlookSession object:

Dim MyNewMailHandler As clsNewMailHandler


Private Sub Application_Quit()
Set MyNewMailHandler = Nothing
End Sub


Private Sub Application_Startup()
Set MyNewMailHandler = New clsNewMailHandler
End Sub

Restart Outlook and you are in business! Obviously you could rearrange this code to suit your own purpose and condense some of the code into the one class module but I find this modularisation makes the code much easier to understand and manage.