Archive email in outlook

I really like the Archive function in Gmail. Unfortunately at work we use a Microsoft Exchange server which means I've been using Microsoft Outlook for the past few years. In order to clean up my inbox I've resorted to having my own "Archived email" pst files elsewhere since I can't keep all of my email on the server.

One thing that has bothered me has been the lack of the Archive button to just move all of my email to my Archived email pst. There is a "Move to folder" button, but that is a two step proces.

In the name of efficiency I produced the following macro:

Sub Archive()
Dim objFolder As Outlook.Folder
Dim objNS As Outlook.NameSpace
Dim objItem As Object

Set objNS = Application.GetNamespace("MAPI")

'Get the correct "Archive" folder
Set objFolder = objNS.Folders("- Personal Folders 2011").Folders("Archived Inbox 2011")

If objFolder Is Nothing Then
MsgBox "This folder doesn't exist!", vbOKOnly + vbExclamation, "INVALID FOLDER"
Exit Sub
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
objItem.Move objFolder
Next

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

 Assigning this to a button on the toolbar is almost like archiving my email in Gmail. It isn't quite as efficient and searching isn't as easy if you're using outlook's search (I've given up on standard Microsoft search and replaced it with Google Desktop Search), but at least I have a "one click" button to move my email to my desired folder.

Now if only I could fix the rest of outlook.