Skywalker2 has a problem:
I exported my email from Outlook Express to Outlook 2007 as per your Article "Moving from Outlook Express to Outlook". I have 2 pop3 email accounts setup. The emails in all the exported folders display the same account (only one account). I would like to be able to see which email account each email was sent to, without having to open the email and read the header.
The macro below will change the account shown in the Email Account field and replies will use that account AFTER you refresh the folder. (Switch to another folder then come back). This will work on POP3 and IMAP messages provided the IMAP messages are in a local pst. It won't work on Exchange mailboxes. The macro runs on selected messages so you easily test it on a small number of messages before running it on all of your messages.
I tested this code in Outlook 2013 and it should work with at least Outlook 2007 and Outlook 2010. It may work with older versions.
You need to install Redemption and set it as a reference in Outlook's VB Editor (Tools, References).
- Open the VB Editor using Alt+F11.
- Right click on Project1 and choose Insert > Module.
- Copy the code below and paste into the new module.
- Set the reference to Redemption in Tools, References.
- Change the email address and account name in the code before running the ChangeAccount macro.
Select the messages you want to check then run the macro.
Option Explicit Private Const PR_HEADERS = &H7D001E Private Const PR_ACCOUNT = &H80F8001E Sub ChangeAccount() On Error Resume Next Dim objItem As Outlook.MailItem For Each objItem In Application.ActiveExplorer.Selection ' Check if this was sent to a specific address If CheckMessageRecipient(objItem, "email@example.com", False) Then ' If yes, change the account Call SetMessageAccount(objItem, "Account name as shown in Account settings", True) End If Next Set objItem = Nothing End Sub 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 ' 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
If you want to set the account when you download email, see VBA Adventures: Automatic Email Account Assignment in Outlook
If you don't care about the account name but want the message to be sent using the correct account, see Reply using the address a message was sent to