An Outlook Macro to Archive Items like GMail

I’m a big fan of Gmail’s archive feature- I can move items out of the inbox quickly and find them later with search.  To mimic this behavior at work with outlook, I’ve created this quick and dirty macro which does the job.  Simply create a folder named “archive” in your mailbox.  When you run the macro, it will move the current item in your inbox to that folder.  I’ve created a keystroke which lets me run the macro easily.

Sub ArchiveItem()

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)
 Set objFolder = objInbox.Parent.Folders("Archive")

'Assume this is a mail folder
 If objFolder Is Nothing Then
 MsgBox "This folder doesn't exist!", vbOKOnly + vbExclamation, "INVALID FOLDER"
 End If

 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
 objItem.Move objFolder
 End If
 End If
 Next

 Set objItem = Nothing
 Set objFolder = Nothing
 Set objInbox = Nothing
 Set objNS = Nothing
End Sub