Outlook VB macro for moving mail

Been meaning to post this quickie for awhile. Took me a good bit of searching and tweaking but I’ve been using this macro for about two months to move email in my IMAP account in Outlook (2007) to my archive folder. Then I bound it to a hotkey combo by adding it to my menu bar and placing an ampersand in front of the “trigger key.” For example, I added the macro to the menu bar and then renamed it to “&@rchive” to move the mail to the archive folder. Now when I press “Alt-@” (really Alt-Shift-2) when I have mail selected it moves the mail to the appropriate folder. You can’t overload hotkeys and since “Alt-A” was already taken I had to choose something else.

Note I’ve tested this with Cyrus. Other IMAP servers may have different namespacing conventions.

Sub MoveSelectedMessagesToBAArchives()
On Error Resume Next

Dim objFolder As Outlook.MAPIFolder, objInbox As Outlook.MAPIFolder
Dim objNS As Outlook.NameSpace, objItem As Outlook.MailItem

Dim TestFolder As Outlook.Folder
Dim FoldersArray As Variant
Dim i As Integer
Set objNS = Application.GetNamespace(“MAPI”)

‘Convert folderpath to array
FoldersArray = Split(“BA\Inbox\Archives”, “\”)
Set TestFolder = Application.Session.Folders.Item(FoldersArray(0))
Dim SubFolders As Outlook.Folders
If Not TestFolder Is Nothing Then
For i = 1 To UBound(FoldersArray, 1)
Set SubFolders = TestFolder.Folders
Set TestFolder = SubFolders.Item(FoldersArray(i))
If TestFolder Is Nothing Then
Set objFolder = Nothing
End If
Next
End If
‘Return the TestFolder
Set objFolder = TestFolder

‘Set objFolder = objNS.GetFolder(“BA\Inbox\Archives”)
‘Set objFolder = objInbox.Folders(“Archives”)
‘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

Sorry for the busted formatting. WordPress sucks sometimes.