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.

17 comments:

JP said...

Hey Wazza, great code! Why not use the ItemAdd event instead of the NewMail event, this would probably capture all of the emails.


HTH,
JP

Wazza said...

Thanks JP.

Outlook Help says the following about the ItemAdd event:

Occurs when one or more items are added to the specified collection. This event does not run when a large number of items are added to the folder at once.

The documentation states that for NewMailEx This event passes a list of entry IDs of all the items received in the Inbox since the last time the event was fired.

So it sounds more reliable than ItemAdd which is why I use it. Having said that, I don't know why my code doesn't always reset the account but I'm guessing it is because the time-order in which event code and rules code runs is not fixed and may cause conflicts (not that I get any errors generated).

JP said...

Hmm for some reason I thought it was the other way around. Must've got my wires crossed. Thanks.

--JP

Anonymous said...

Hi Wazza. I am new to Outlook and programming and we have outlook 2003 installed. We access from the POP3 accounts on a firewall and also from Exchange, so we have 2 accounts on our Outlook. Do you happen to have some snippet code that will automatically select the account such as POP3 or Exchange to Deliver my messages? I established that if in the TO subject the symbol @ is included to use the Exchange. Have a great day! I will continue poudning on this thing, but had to ask..

Wazza said...

Dallas 101,

I'm pretty sure you can use a similar approach to mine except you want to sink the ItemSend event which has the following description:

ItemSend Event occurs whenever an item is sent, either by the user through an Inspector (before the inspector is closed, but after the user clicks the Send button) or when the Send method is used in a program. This event is not available in Microsoft Visual Basic Scripting Edition (VBScript).

Sub object_ItemSend(ByVal Item As Object, Cancel As Boolean)
object An expression that evaluates to an Application object.

Item Required. The item being sent.

Cancel Optional. False when the event occurs. If the event procedure sets this argument to True, the send action is not completed and the inspector is left open.


In your clsNewMailHandler class you'll need to add code in the ItemSend event of the oApp object to call SetEmailAccount.

Your version of SetEmailAccount will need to CheckMessageSubject or some such instead of CheckMessageRecipient. Check the Redemption site for ideas.

I'm not sure if you can change the account of a New Mail Item so just try it and let us know how you get on.

Regards,
Wazza

Unknown said...

Hi,

I understand that your VBA code is for making replies go out through a specific account. Is there a way to make this code work for newly created messages for contacts already in the address book or in a specific list? Say I have a group of friends to whom I only write from a specific email account, I would like Outlook to automatically send new emails from this account instead of the default one every time I click on the New Mail Message button.

By the way and unfortunately, my knowledge of VBA is nil. I only know how to add references, and copy paste a module in Outlook VBA and run it from there.

Is there a simple way to adapt your code to do what I described earlier?

Thank you for your help.
Regards,
Lan

Wazza said...

Ian,

As I understand it, you want a new email to auto-select the account you use to send it based on the recipient list.

Hmmm. Before looking into whether I can do this for a new mail message (and it should be possible I think as long as it has been saved) the question I have is how you would associate the account with a contact? What happens if there are multiple recipients and the associations disagree? If there is a signature associated with the account, what happens to that text when we change to a different account? And so on.

Have you given any thought to this aspect of the problem?

Regards,
Wazza

www.randek-bautech.com said...

http://vbaexcel.eu

I found your webpage very useful! The link above is to an other site that has good vba code!

Thanks!

Unknown said...

I try debug the code, because it doesn't seem to work for me.
Should the strAccount in

Call rUtils.HrSetOneProp(oItem.MAPIOBJECT, PR_ACCOUNT, strAccount, blnSave)

Just be the name of the account I have? It doesn't seem to impact on the account the message is associated with. (By viewing the field "Account" in my message list).

If I try get the account name, then it just returns a blank string back (instead of the account name that i can see in my message list). I'm using outlook 2007, any idea?

Unknown said...

Oh and by the way, I had to enable macro's for it to run the code (in the trust center)- maybe a outlook 2007 problem only.

Wazza said...

Matthew,

Yes, since I moved to Outlook 2007, it hasn't worked properly for me either. When I reply to a message sent to my secondary account, the text at the top of the form says "This message will be sent using the bainsworld account." but if I click on the accounts button, it has the primary account ticked.

Your message prompted me to investigate and I have changed SetMessageAccount to use the RDO objects and this now works. See below...

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

Unknown said...

Great thanks, you are a legend, this worked.

I sometimes have connectivity issues, and the GetInternetHeaders function fails with an Outlook response error, why on earth does it try use my local OST file rather?

Regards
Matt

Wazza said...

@Matthew, I don't have any exchange connection so not sure what is happening for you. What is the specific error you get?

Goldfinger said...

Awesome Thanks! Just a few minutes of tweaking tnd there it is!!

Karan said...

Dear Sir,

my website name is www.usemytips.in hosted on yahoo server and they have alloted me 1000 email ids..and i have email databse in excel.

Following are the properties of outlook mail. I have around 35 email ids. I wish to do mass mailing but i can send only 250 email per day / per ID.
and every time i need to change out look email properties.

i will create one table in excel with following headings.

Display Name
Email Address
Usename
Password

Is there any option in excel vba where my codes will read from this table and change the outlook properties and send the mail.
One its reach to 250 my cursor will move to next row.

i have basic knwlege of excel vba
would be great help if you share some knowledge.

Regards
Shankar More
shankar.more@lodhagroup.com
India

Celad said...

Hey - I know I'm posting a comment on an ancient blog post, and it's off-topic (but it is still Outlook and vba ; - ), but I can't find any way in code to change move the focus from the Subject on a new mailitem (standard Outlook New E-mail, not a custom form) so that the field will update. Do you have any ideas?

egarobar said...

Hi there,
I've just tried to install this, as it's almost exactly what I want to achieve, and looks great. But it's not working for me. Can you suggest anything? I've inserted a line

MsgBox "Done"

after the line that changes the property, and it doesn't get actioned.

My code says
If CheckMessageRecipient(oItem, TC_BAINSWORLD_ACCOUNT, True) Then
' Yes it was - change the account
Call SetMessageAccount(oItem, TC_PF_ACCOUNT, True)
MsgBox "Done"

Thanks in advance...