modArchive.bas

'Outlook VB Macro to move selected mail item(s) to a target folder

Sub MoveToArchive()
On Error Resume Next

Dim ns As Outlook.NameSpace
Dim moveToFolder As Outlook.MAPIFolder
Dim objItem As Object

Set ns = Application.GetNamespace("MAPI")

If Application.ActiveExplorer.Selection.Count = 0 Then
   MsgBox ("No item selected")
   Exit Sub
End If

'Define path to the target folder
Set archiveBaseFolder = ns.Folders("Personal Folders").Folders("Archive")
If archiveBaseFolder Is Nothing Then
   MsgBox "Base archive folder not found!", vbOKOnly + vbExclamation, "Move Macro Error"
   Return
End If

Application.Cursor = xlWait
For Each objItem In Application.ActiveExplorer.Selection
    Dim objDate As Date
    objDate = objItem.ReceivedTime
    Dim yearFolderName As String
    yearFolderName = Year(objDate)
    Set yearFolder = archiveBaseFolder.Folders(yearFolderName)
    If yearFolder Is Nothing Then
        archiveBaseFolder.Folders.Add (yearFolderName)
        Set yearFolder = archiveBaseFolder.Folders(yearFolderName)
    End If
    
    Dim monthFolderName As String
    monthFolderName = Format(objDate, "mm - mmmm")
    Set monthfolder = yearFolder.Folders(monthFolderName)
    If monthfolder Is Nothing Then
        yearFolder.Folders.Add (monthFolderName)
        Set monthfolder = yearFolder.Folders(monthFolderName)
    End If
    
    Set moveToFolder = monthfolder
    
    If moveToFolder Is Nothing Then
       MsgBox "Target folder not found!", vbOKOnly + vbExclamation, "Move Macro Error"
    End If

    objItem.Move moveToFolder
    Set monthfolder = Nothing
    Set yearFolder = Nothing
Next
Application.Cursor = xlDefault
Set objItem = Nothing
Set moveToFolder = Nothing
Set ns = Nothing

End Sub