Move Completed Emails

This sample demonstrates how to move an item automatically to a subfolder of the inbox as soon as you flag it as completed. Here that subfolder is called 'File'.

For Outlook 2003 it doesn't work to move a MailItem is it is flagged completed. A workaround then is to use the CDO 1.21 library.

  How to add macros to Outlook

Private WithEvents Items As Outlook.Items

Private Sub Application_Startup()
  Dim Ns As Outlook.NameSpace

  Set Ns = Application.GetNamespace("MAPI")
  Set Items = Ns.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub Items_ItemChange(ByVal Item As Object)
  MoveCompletedItem Item
End Sub

Private Sub MoveCompletedItem(Item As Object)
  Dim Ns As Outlook.NameSpace
  Dim Inbox As Outlook.MAPIFolder
  Dim Subfolder As Outlook.MAPIFolder
  Dim Mail As Outlook.MailItem
  Dim Msg As MAPI.Message
  Dim SubFolderName As String

  SubFolderName = "File"

  If TypeOf Item Is Outlook.MailItem Then
    Set Mail = Item

    If Mail.FlagStatus = olFlagComplete Then
      Set Ns = Application.Session

      Set Inbox = Ns.GetDefaultFolder(olFolderInbox)
      Set Subfolder = Inbox.Folders(SubFolderName)

      Set Msg = GetCDOMessage(Item)
      Msg.MoveTo Subfolder.EntryID, Subfolder.StoreID
    End If
  End If
End Sub

Private Function GetCDOMessage(Item As Object) As MAPI.Message
  On Error Resume Next
  Dim Session As MAPI.Session
  Dim sEntryID As String
  Dim sStoreID As String

  sEntryID = Item.EntryID
  sStoreID = Item.Parent.StoreID
  Set Session = CreateObject("MAPI.Session")
  Session.Logon , , False, False, , True
  Set GetCDOMessage = Session.GetMessage(sEntryID, sStoreID)
End Function