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
Tools
Send Guard will detect and prompt you whenever you make any of these mistakes and more: forget to send an attachment you promised in a message, Reply-to-All or forget to Reply-to-All, send emails using the wrong email account, send emails with blank or incorrect subjects, said something you oh-so-knew-better than to say. |