VBA Macro to Move Aged Email Messages To Folder

[jasono]

Hi All, if anyone can provide help I would greatly appreciate it. I found some vb online to do exactly what I wanted to do, but I can't get it to work. I'm losing tons of valuable emails due to the companies email retention policy. Currently spending too much time trying to find these emails before they age out and move them to my Mailstore program.

I pasted this code into a new module and also into ThisOutlookSession and neither works.

Thanks
Jason


Sub MoveAgedMail()

Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objSourceFolder As Outlook.MAPIFolder
Dim objDestFolder As Outlook.MAPIFolder
Dim objVariant As Variant
Dim lngMovedItems As Long
Dim intCount As Integer
Dim intDateDiff As Integer
Dim strDestFolder As String

Set objOutlook = Application
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderInbox)

' use a subfolder under Inbox
Set objDestFolder = objSourceFolder.Folders("01_Aged")

For intCount = objSourceFolder.Items.Count To 1 Step -1
Set objVariant = objSourceFolder.Items.Item(intCount)
DoEvents
If objVariant.Class = olMail Then

intDateDiff = DateDiff("d", objVariant.ReceivedTime, Now)

' I'm using 7 days, adjust as needed.
If intDateDiff > 300 Then

objVariant.Move objDestFolder

'count the # of items moved
lngMovedItems = lngMovedItems + 1

End If
End If
Next

' Display the number of items that were moved.
MsgBox "Moved " & lngMovedItems & " messages(s)."
Set objDestFolder = Nothing
End Sub