A popular request is the ability to assign a Outlook account to a contact, so every time you send a message to that contact, Outlook uses the desired account automatically. Although Outlook doesn't have this feature, you can use VBA to pick the account that will be used to send the message.

Don't want to use VBA? See Tools for third party utilities. The utilities will work with older versions of Outlook.

This code sample checks the category assigned to a contact and picks the sending email account based on the category. Assign the macro to a toolbar, QAT, or ribbon command and use in place of the New button. You can configure the macro to either tell you that you do not have a contact selected or select the default account when either a category matching an account is not found or you are in a folder other that Contacts.

In this iteration, it requires only 1 category per contact. For it to work with Contacts with more than one category assigned, you need to parse the Categories string, looking for the right keyword name. That is more work than this lazy programmer does. :)

Assign the account display name as it appears in Account Settings as the category. In Outlook 2010, this is usually the email address but it can be changed to a friendly name (double click on the account, then More Settings).

This code checks the category and links it to an account. If no match is found, it uses default account. Note: This uses the *default* account as set in Account Settings, not the account assigned to the current folder in Outlook 2010.

Choose Account based on Contact Category

To use: Press Alt+F11 to open the VBA Editor. You can paste this into ThisOutlookSession or insert a new module.

Select a contact and run the macro.

Public Sub AccountByContact()
Dim oAccount As Outlook.Account
Dim oContact As Outlook.ContactItem
Dim strAccount As String
Dim olNS As Outlook.NameSpace
Dim objMsg As MailItem

Set olNS = Application.GetNamespace("MAPI")
Set objMsg = Application.CreateItem(olMailItem)

If TypeName(ActiveExplorer.Selection.Item(1)) = "ContactItem" Then
 Set oContact = ActiveExplorer.Selection.Item(1)
 
 On Error Resume Next
 
 strAccount = oContact.Categories
 
 For Each oAccount In Application.Session.Accounts
  If oAccount.DisplayName = strAccount Then
     objMsg.SendUsingAccount = oAccount
       Else
     objMsg.SendUsingAccount = olNS.Accounts.Item(1)
  End If
Next

  objMsg.To = (oContact.Email1Address)
  objMsg.Display

Set objMsg = Nothing
Set olNS = Nothing

Else
' Either tell user the selection is not a contact 
'MsgBox "Sorry, you need to select a contact"
  
' Or open a new message using the default account
objMsg.Display

End If

End Sub

Check the Contact Category on Send

This macro checks for a contact's category when you send the message. If the Category matches the sending account name, the message is sent. If it does not match (or there is no category assigned), you are asked to confirm the send.

As written, this macro checks only the first recipient in a message. The contact cannot be assigned more than one category.

To use, paste into ThisOutlookSession.

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
 
'On Error Resume Next
Dim folContacts As Outlook.MAPIFolder
Dim colItems As Outlook.Items
Dim oContact As Outlook.ContactItem
Dim sSentTo As String

 Dim recips As Outlook.Recipients
 Dim recip As Outlook.Recipient
 Dim pa As Outlook.PropertyAccessor
  
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))
 Debug.Print Address
 
 strAccount = Item.SendUsingAccount

Set folContacts = Session.GetDefaultFolder(olFolderContacts)
Set colItems = folContacts.Items
Set oContact = colItems.Find("[email1address] = '" & Address & "'")
If Not (oContact Is Nothing) Then
cCategory = oContact.Categories
Else
cCategory = ""
End If

If strAccount <> cCategory Then
      prompt$ = "You sending this from " & strAccount & ". Are you sure you want to send it?"
       If MsgBox(prompt$, vbYesNo + vbQuestion + vbMsgBoxSetForeground, "Check Sending Account") = vbNo Then
         Cancel = True
       End If
Else
'checks first address, exits & sends if a match
Exit Sub
End If
 
Next
End Sub