Outlook 2003 Macro - Move messages to folder, create folder, Inbox archive

Sub Archive()

    On Error Resume Next
    Dim EmailArchiveFolder As String
    'this folder, if doesnt already, will exist in the Inbox folder
    EmailArchiveFolder = "Inbox_Archive"

    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.Folders(EmailArchiveFolder)

'Assume this is a mail folder

 
    If objFolder Is Nothing Then

        MsgBox "This folder doesn't exist! It will be created.", vbOKOnly + vbExclamation, "INVALID FOLDER"
        Set objFolder = objInbox.Folders.Add(EmailArchiveFolder)

    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