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 strDestFolder As String
Dim lastverb, lastaction As String
Dim propertyAccessor As Outlook.propertyAccessor
Set objOutlook = Application
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderInbox)
For intCount = objSourceFolder.Items.count To 1 Step -1
Set objVariant = objSourceFolder.Items.Item(intCount)
DoEvents
If objVariant.Class = olMail Then
Set propertyAccessor = objVariant.propertyAccessor
lastverb = "http://schemas.microsoft.com/mapi/proptag/0x10810003"
lastaction = propertyAccessor.GetProperty(lastverb)
' 102, 103, 104 are replied, forwarded, reply all
If lastaction > 7 Then
' use your datafile name and each folder in the path
' the example uses an email address because Outlook 2010
' uses email addresses for datafile names
Set objDestFolder = objNamespace.Folders("me@domain.com"). _
Folders("Inbox").Folders("completed")
objVariant.Move objDestFolder
'count the # of items moved
lngMovedItems = lngMovedItems + 1
Set objDestFolder = Nothing
End If
End If
Next
' Display the number of items that were moved.
MsgBox "Moved " & lngMovedItems & " messages(s)."
Set objOutlook = Nothing
End Sub