Change the email account on received email

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).

1. Open the VB Editor using Alt+F11.
2. Right click on Project1 and choose Insert > Module.
3. Copy the code below and paste into the new module.
4. Set the reference to Redemption in Tools, References.
5. 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, "alias@domain.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