How to move messages from a specific account? - vba

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.