Macro - Move Deleted Items to Archived Folder

[e.shol]

Hello,

I am fairly new to VBA (for the past month or two, I've been relying on recording macros in Excel then tweaking to my ability), and am need of some assistance for writing a macro in Outlook.

For the macro, I want something that will run every time I open the program, moving any items in my 'Deleted' folder that are older than 60 days to an archived folder called 'Archived Deleted Items' (nested within a folder called 'Retention Folders').

Any assistance is much appreciated - thanks!

[JP2112]

Welcome to the forum. Unfortunately, Outlook doesn't let us record macros.

There are a couple of events that fire when Outlook starts, the one I use is Application_Startup (http://msdn.microsoft.com/en-us/library/bb147656(v=office.12).aspx):

Private Sub Application_Startup()

End Sub

First you'll want a reference to the items in the Deleted Items folder. Since this is one of Outlook's default folders, a reference is easy:

Private Sub Application_Startup()

Dim delItems As Outlook.Items
Set delItems = Outlook.Session.GetDefaultFolder(olFolderDeletedItems).Items

End Sub

I assume here that you want the Deleted Items folder for your default mailbox.

Now we need to filter the Items collection so we only have items that are > 60 days old. We use the Restrict (http://msdn.microsoft.com/en-us/library/bb220369(v=office.12).aspx) method to return a filtered subset of the items collection we are working with.

Private Sub Application_Startup()

Dim delItems As Outlook.Items
Dim olddelItems As Outlook.Items
Set delItems = Outlook.Session.GetDefaultFolder(olFolderDeletedItems).Items

Set olddelItems = delItems.Restrict("[ReceivedTime] > " & Quote(Date - 60))
End Sub

Function Quote(MyText) As String
' from Sue Mosher's excellent book "Microsoft Outlook Programming"
Quote = Chr(34) & MyText & Chr(34)
End Function

Now we want to move the items in the olddelItems collection to the 'Archived' folder. We need to loop backwards when moving items. The final procedure looks like this:

Private Sub Application_Startup()

Dim delItems As Outlook.Items
Dim olddelItems As Outlook.Items
Dim archiveFolder As Outlook.MAPIFolder
Dim i As Long

' get items collection from Deleted Items folder
Set delItems = Outlook.Session.GetDefaultFolder(olFolderDeletedItems).Items
' get only items over 60 days old
Set olddelItems = delItems.Restrict("[ReceivedTime] > " & Quote(Date - 60))

set archiveFolder = Outlook.Session.GetDefaultFolder(olFolderInbox).Folders("Retention Folders").Folders("Archived Deleted Items")
' move items to archive folder
For i = olddelItems.Count To 1 Step -1
olddelItems.Item(i).Move archiveFolder
Next i

End Sub

Function Quote(MyText) As String
' from Sue Mosher's excellent book "Microsoft Outlook Programming"
Quote = Chr(34) & MyText & Chr(34)
End Function

This code should be placed in the ThisOutlookSession module, then Outlook should be restarted.

[e.shol]

Gave that a shot, and received an error that the object could not be found in the "Set archiveFolder" line - I think it's because the folders I'm moving the deleted items to aren't located in the inbox, they are their own set of folders in the mailbox.

[JP2112]

I assumed that folder was under the default Inbox. If not, you need to point the object variable to the correct hierarchy.

[e.shol]

Can you send me a sample of what it should look like without directing it to the GetDefaultFolder(Inbox) portion?

[JP2112]

There is an example in this thread:

http://www.vbaexpress.com/forum/showthread.php?t=42363

You can see how to reference any mailbox using Session.Folders and how to reference subfolders by walking the hierarchy using the Folders Collection.

[e.shol]

This is my code so far. What I'm doing is taking messages in the "Deleted" folder and putting them into an archived folder after they reach an age of 60 days. The error I'm getting is at the 'Set archiveFolder' line...

Private Sub Application_Startup()

Dim delItems As Outlook.Items
Dim olddelItems As Outlook.Items
Dim archiveFolder As Outlook.MAPIFolder
Dim i As Long

' get items collection from Deleted Items folder
Set delItems = Outlook.Session.GetDefaultFolder(olFolderDeletedItems).Items
' get only items over 60 days old
Set olddelItems = delItems.Restrict("[ReceivedTime] > " & Quote(Date - 60))

Set archiveFolder = Outlook.Session.Folders("Retention Folders").Folders("Permanent (e.g. Corporate Records)").Folders("Archived Deleted Items")

' move items to archive folder
For i = olddelItems.Count To 1 Step -1
olddelItems.Item(i).Move archiveFolder
Next i

End Sub

Function Quote(MyText) As String
Quote = Chr(34) & MyText & Chr(34)
End Function

[JP2112]

I don't think "Retention Folders" is the name of a mailbox in your Outlook. Would you please run this code and post the output? Copy from the Debug Window and paste it here.

Sub GetMailBoxNames()
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim i As Long
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
For i = 1 To olNS.Folders.count
Debug.Print olNS.Folders(i).name
Next i
End Sub

[e.shol]

Not sure how to get the list of folders in the debug window with the above code, so I've taken a screenshot of my Outlook folders pane...

http://i.imgur.com/g7bm3.gif

As you can see, it looks like Retention Folders is a folder separate from the Inbox.

[JP2112]

Retention Folders is on the same level as the Inbox. So you need to walk the Folders hierarchy. This is the correct reference:


Outlook.Session.Folders("Mailbox - xxxxxxxx").Folders("Retention Folders")