Moving Outlook messages with one click (2)

I now have Outlook 2013, multiple accounts and have upgraded from Exchange server 21007 to 2010 which meant my short cut macros have got lost.  so I am starting again and revising my old post.

I need to create a macro to move the current e-mail to a specified folder, normally Inbox Done as a sub folder of my inbox.  This allows me to keep my inbox clear and not read emails twice and not action them.

1) Create a macro

a) Show the developer tab in Outlook.
Microsoft help is here.

File->Options->Customize Ribbon>Developer (checked)

b) Developer –>Macros –> (type new name) –>Create
This creates a stub and open it in the VBA editor, eg:

Sub test()
  MsgBox "Hi"
End Sub

This can now be run from the developer macros window.

I couldn’t find the general short cut tools that used to be there,  However if you customise the Quick Access Tool bar then Alt+n will give you the nth button.  So in my case Alt+4 gives me my macro.  This works across all of my inboxes.

2) Changed the code to below for moving the message in each mail account:

Sub test()
'Sub MoveSelectedMessagesToToDo()
    On Error Resume Next

    Dim objFolder As Outlook.MAPIFolder, objInbox As Outlook.MAPIFolder

    Dim objNS As Outlook.NameSpace, objItem As Outlook.MailItem

    Set objNS = Application.GetNamespace("MAPI")

    Set objInbox = objNS.GetDefaultFolder(olFolderInbox)

    If Application.ActiveExplorer.Selection.Count = 0 Then
        'Require that this procedure be called only when a message is selected
        Exit Sub
    End If

 
    For Each objItem In Application.ActiveExplorer.Selection
        If objFolder.DefaultItemType = olMailItem Then
            If objItem.Class = olMail Then
                'Find which account this is in
                Set mailParent = objItem.Parent
                'Find the matching object folder for that account
                Set objFolder = mailParent.Folders.Item("Inbox Done")
                'if found the folder then move else error
                If objFolder Is Nothing Then
                    MsgBox "This folder doesn't exist!", vbOKOnly + vbExclamation, "INVALID FOLDER"
                Else
                    'move the item to that folder
                    objItem.Move objFolder
                End If
                Set mailParent = Nothing
                Set objFolder = Nothing
            End If
        End If
    Next

    Set objItem = Nothing
    Set objFolder = Nothing
    Set objInbox = Nothing
    Set objNS = Nothing

End Sub

I also programmed the Microsoft keyboard to provide a hot key for the Alt+4 which mean a single keystroke to do the work.

Apart from my old post, I have used:

http://www.vogella.com/articles/MicrosoftOutlookMacros/article.html