How to move messages from a specific account?

Question

I have multiple accounts attached to Outlook 2010.

I want to move messages from a specific account, older than X days, to a .pst file for local storage.

I found scripts to move messages from the default inbox, but nothing on specifying an account.

I know you can specify an account when sending email using

Set OutMail.SendUsingAccount = Outlook.Application.Session.Accounts.Item(2)

but I can't find anything for looking into another account.

I've found the stores references for the folders (\Inbox and \Sent) and I know how to specify the days old. I have a script that works, but only in my primary account.

Answer 1

After some more searching and testing I came up with the following solution. This was actually from a 2009 post on stackoverflow here: Original VBA

It uses a public function to build the folder locations and a Subroutine to look for received dates older than 60 days and move those files to the specified locations.

The public function is:

Public Function GetFolder(strFolderPath As String) As MAPIFolder
Dim objNS As NameSpace
Dim colFolders As folders
Dim objFolder As MAPIFolder
Dim arrFolders() As String
Dim i As Long

On Error GoTo TrapError

strFolderPath = Replace(strFolderPath, "/", "\")
arrFolders() = Split(strFolderPath, "\")

Set objNS = GetNamespace("MAPI")

On Error Resume Next

Set objFolder = objNS.folders.Item(arrFolders(0))

If Not objFolder Is Nothing Then
    For i = 1 To UBound(arrFolders)
        Set colFolders = objFolder.folders
        Set objFolder = Nothing
        Set objFolder = colFolders.Item(arrFolders(i))

        If objFolder Is Nothing Then
            Exit For
        End If
    Next
End If

On Error GoTo TrapError

Set GetFolder = objFolder
Set colFolders = Nothing
Set objNS = Nothing

Exit_Proc:
    Exit Function

TrapError:
    MsgBox Err.Number & " " & Err.Description

End Function

The subroutine that does the actual work is below.

I added the Pass as Integer to allow the routine to work through two different source and destination folders. If I change the Sub name to Application_Startup it will run whenever outlook is started.

PST Folder Name\Archive-Inbox - PST folder name in Outlook with sub-folder

Email Account Name\Inbox - Account name in Outlook with sub-folder

Sub MoveOldEmail()
    Dim oItem As MailItem
    Dim objMoveFolder As MAPIFolder
    Dim objInboxFolder As MAPIFolder
    Dim i As Integer
    Dim Pass As Integer

For Pass = 1 To 2  
    If Pass = 1 Then
        Set objMoveFolder = GetFolder("PST Folder Name\Archive-Inbox")
        Set objInboxFolder = GetFolder("Email Account Name\Inbox") 
    ElseIf Pass = 2 Then
        Set objMoveFolder = GetFolder("PST Folder Name\Archive-Sent Items")
        Set objInboxFolder = GetFolder("Email Account Name\Sent Items") 
    End If

    For i = objInboxFolder.Items.Count - 1 To 0 Step -1
        With objInboxFolder.Items(i)
       ''Error 438 is returned when .receivedtime is not supported
       On Error Resume Next

            If .ReceivedTime < DateAdd("d", -60, Now) Then
                If Err.Number = 0 Then
                 .Move objMoveFolder
                Else
                  Err.Clear
                End If
            End If
            End With

        Next            
    Next Pass

        Set objMoveFolder = Nothing
        Set objInboxFolder = Nothing

    End Sub

Hope this helps someone else.