Created
January 7, 2013 16:27
-
-
Save anonymous/4476306 to your computer and use it in GitHub Desktop.
Outlook Macro to "Archive" an e-mail to a monthly archive folders in a PST based on e-mail date ("Personal Folders/Archive/YYYY/MM - MMMM"). Derived from http://jmerrell.com/2011/05/21/outlook-macros-move-email/
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| '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 Outlook.MailItem | |
| 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 | |
| For Each objItem In Application.ActiveExplorer.Selection | |
| If moveToFolder.DefaultItemType = olMailItem Then | |
| If objItem.Class = olMail Then | |
| Dim yearFolderName As String | |
| yearFolderName = Year(objItem.CreationTime) | |
| 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(objItem.CreationTime, "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 | |
| End If | |
| End If | |
| Next | |
| Set objItem = Nothing | |
| Set moveToFolder = Nothing | |
| Set ns = Nothing | |
| End Sub |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment