Outlook: Save Selected Items to Folder with Datestamp
- June 11th, 2010
- Write comment
I tend to organize projects in file folders, where I store all project-related information including e-mails. Assign this macro to a toolbar button in Outlook. Select one or more Inbox messages, run the macro, and select the destination folder. Messages will be named according to subject, with a date/timestamp appended. All non-alphanumeric characters are replaced with underscores. (Note: this is a necessary workaround for file naming restrictions within the Windows filesystem.)
Please note: This code utilizes the Microsoft VBScript Regular Expressions 5.5 library (enable it using the Tools- References dialog in the VBA IDE).
Create a VBA module and name it winapi_folderbrowser. Paste the following code into the new module:
""" BEGIN CODE Private Const BIF_RETURNONLYFSDIRS As Long = &H1 Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2 Private Const BIF_RETURNFSANCESTORS As Long = &H8 Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000 Private Const BIF_BROWSEFORPRINTER As Long = &H2000 Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000 Private Const MAX_PATH As Long = 260 Type BrowseInfo hOwner As Long pidlRoot As Long pszDisplayName As String lpszINSTRUCTIONS As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type Type SHFILEOPSTRUCT hwnd As Long wFunc As Long pFrom As String pTo As String fFlags As Integer fAnyOperationsAborted As Boolean hNameMappings As Long lpszProgressTitle As String End Type Declare Function SHGetPathFromIDListA Lib "shell32.dll" ( _ ByVal pidl As Long, _ ByVal pszBuffer As String) As Long Declare Function SHBrowseForFolderA Lib "shell32.dll" ( _ lpBrowseInfo As BrowseInfo) As Long Function BrowseFolder(Optional Caption As String = "") As String Dim BrowseInfo As BrowseInfo Dim FolderName As String Dim ID As Long Dim Res As Long With BrowseInfo .hOwner = 0 .pidlRoot = 0 .pszDisplayName = String$(MAX_PATH, vbNullChar) .lpszINSTRUCTIONS = Caption .ulFlags = BIF_RETURNONLYFSDIRS .lpfn = 0 End With FolderName = String$(MAX_PATH, vbNullChar) ID = SHBrowseForFolderA(BrowseInfo) If ID Then Res = SHGetPathFromIDListA(ID, FolderName) If Res Then BrowseFolder = Left$(FolderName, InStr(FolderName, vbNullChar) - 1) End If End If End Function ''' END CODE
Create a new VBA module and name it mymacros. Paste the following code into the new module:
''' BEGIN CODE Sub SaveMsgToFolderWithSubjectAndTimestamp() Dim Item As MailItem Dim strTargetFilename As String Dim strTargetPath As String Dim objRegExp As New RegExp With objRegExp .Global = True .IgnoreCase = True .Pattern = "[^\w+]" End With strTargetPath = BrowseFolder Dim SelectedItems As Selection Set SelectedItems = Outlook.ActiveExplorer.Selection For Each Item In SelectedItems strTargetFilename = objRegExp.Replace(Item.Subject, "_") + "_" + Format(Item.ReceivedTime, "yyyy_mm_dd_hhnnss") Item.SaveAs strTargetPath + "\" + strTargetFilename + ".msg", olMSG Next Item End Sub ''' END CODE
Assign the macro SaveMsgToFolderWithSubjectAndTimestamp to a custom toolbar button and you’re all set.
One step further: Save attachments!
The code has been extended as follows: If message has attachments, a new folder is created, named according to the message subject, with “_ATTACHMENTS” appended, and all attachments are saved in the new folder.
Sub SaveMsgToFolderWithSubjectTimestampAttachments() Dim Item As MailItem Dim strTargetFilename As String Dim strTargetPath As String Dim Atmt As Attachment Dim strTargetAttachmentsFolderPath As String Dim objRegExp As New RegExp With objRegExp .Global = True .IgnoreCase = True .Pattern = "[^\w+]" End With strTargetPath = BrowseFolder Dim SelectedItems As Selection Set SelectedItems = Outlook.ActiveExplorer.Selection For Each Item In SelectedItems strTargetFilename = objRegExp.Replace(Item.Subject, "_") + "_" + Format(Now(), "yyyy_mm_dd_hhnnss") Item.SaveAs strTargetPath + "\" + strTargetFilename + ".msg", olMSG If Item.Attachments.Count > 0 Then ' Create new folder strTargetAttachmentsFolderPath = strTargetPath + "\" + strTargetFilename + "_ATTACHMENTS" MkDir strTargetAttachmentsFolderPath ' Save Attachments For Each Atmt In Item.Attachments Atmt.SaveAsFile strTargetAttachmentsFolderPath + "\" + Atmt.DisplayName Next Atmt End If Next Item End Sub









