To move selected mailitems. No code for searching for items.
Should be valid in 2007 and 2010 (MAPIFolder is 2003, now Folder, but still works)
Code:
Sub MoveToFiled()
'On Error Resume Next ' <--- Do not use this unless there is a specific purpose
' Never at the start.
' Not when debugging.
'
' Turn it off as quickly as possible with
' On Error GoTo 0
Dim ns As Outlook.Namespace
Dim moveToFolder As Outlook.MAPIFolder
'Dim objItem As Outlook.mailitem
Dim objItem As Object ' <--- the selected objItem may not be a mailitem
Set ns = Application.GetNamespace("MAPI")
On Error Resume Next ' To bypass the error when the target folder is not found.
' moveToFolder will be Nothing
' Enter the exact names of the folders
' No slashes. Walk the path one folder at a time.
Set moveToFolder = ns.folders("Personal Folders").folders("Drafts")
On Error GoTo 0 ' No need for On Error Resume Next any more
If moveToFolder Is Nothing Then
MsgBox "Target folder not found!", vbOKOnly + vbExclamation, "Move Macro Error"
' There will an error moving the selected mail to a folder set to Nothing
' since the On Error Resume Next is off
' Leave now before this occurs.
GoTo ExitRoutine
Else
Debug.Print "moveToFolder: " & moveToFolder
End If
If Application.ActiveExplorer.Selection.count = 0 Then
MsgBox ("No item selected")
' Exit Sub <--- forgot to clean up
GoTo ExitRoutine
End If
For Each objItem In Application.ActiveExplorer.Selection
If moveToFolder.DefaultItemType = olMailItem Then
If objItem.Class = olMail Then
objItem.Move moveToFolder
End If
End If
Next
ExitRoutine:
Set objItem = Nothing
Set moveToFolder = Nothing
Set ns = Nothing
End Sub