View Single Post
 
Old 11-12-2014, 03:31 PM
niton niton is offline Windows 7 64bit Office 2010 64bit
Competent Performer
 
Join Date: Jul 2012
Posts: 102
niton is on a distinguished road
Default

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
Reply With Quote