Back to Cattail.Nu Index

Outlook 2007 Visual Basic Script to Save Emails/Attachments

This script will let you save emails and their attachments with a single button click.
Symbol characters are removed from the file titles.
For easy file listing, sorting, and scripting, these are saved with this naming convention:

Option Explicit

' Outlook 2007 Visual Basic Script to Save Emails and their Attachments to Files.

' Theresa L. Ford, 1/2010
' http://www.cattail.nu

' Instructions:
' 0. Open Outlook
' 1. Copy This Code
' 2. Tools | Macro | Visual Basic Editor
' 3. Insert | Module
' 4. Paste in Code and Save
' 5. Edit the emailPath and attachmentPath variables.
' 6. Close the Visual Basic Editor window to return to Outlook.
' 7. Tools | Customize
' 8. Commands
' 9. Macros (left window)
' 10. Drag the Save_Email macro up onto the toolbar.

' To use:
' 1. Highlight/select emails you want to save.
' 2. Click toolbar button.

' References
' http://www.vbforums.com/showthread.php?t=534087
' http://verychewy.com/archive/2006/04/12/outlook-macro-to-move-an-email-to-folder.aspx
' http://www.vbaexpress.com/kb/getarticle.php?kb_id=522

' Note: will fail on calendar meeting invites

Const olSaveAsTxt = 0
Const olSaveAsRTF = 1
Const olSaveAsMsg = 3

' Path to save in must already exist.

Const emailPath As String = "c:\mail\"
Const attachmentPath As String = "c:\mail\"

Sub Save_Email()
   ' mail stuff
   Dim objItem As Outlook.MailItem
   Dim dtDate As Date
   Dim sName As String
   Dim sFile As String
   Dim sExt As String

   ' attachment stuff
   Dim olAtt As Attachment
   Dim i As Integer
   Dim sAttachmentName As String

   If Application.ActiveExplorer.Selection.Count = 0 Then
       'Require that this procedure be called only when a message is selected
       Exit Sub
   End If

   sExt = ".txt"

   For Each objItem In Application.ActiveExplorer.Selection
       If objItem.Class = olMail Then
           sName = objItem.Subject
           ReplaceCharsForFileName sName, "_"

           dtDate = objItem.ReceivedTime

           sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
               vbUseSystem) & Format(dtDate, "_hhnnss", _
               vbUseSystemDayOfWeek, vbUseSystem) & "_" & sName & sExt

           objItem.SaveAs emailPath & sName, olSaveAsTxt

           ' Attachment Stuff
           If objItem.Attachments.Count > 0 Then
               For i = 1 To objItem.Attachments.Count
                   Set olAtt = objItem.Attachments(i)
                   sAttachmentName = olAtt.FileName
                   ReplaceCharsForFileName sAttachmentName, "_"

                    'save the attachment
                   olAtt.SaveAsFile emailPath & sName & "___" & sAttachmentName

               Next
           End If

       End If
   Next

   Set objItem = Nothing
   Set olAtt = Nothing

End Sub


Private Sub ReplaceCharsForFileName(sName As String, _
 sChr As String _
)

   ' can't remove periods because you lose the attachment file type

   ' I script a lot of things, so I don't want symbols and spaces in the file names.
   ' Put an apostrophe in front of anything you want to keep.

   sName = Replace(sName, "  ", " ")
   sName = Replace(sName, "  ", " ")
   sName = Replace(sName, "  ", " ")

   sName = Replace(sName, "/", sChr)
   sName = Replace(sName, "\", sChr)
   sName = Replace(sName, ":", sChr)
   sName = Replace(sName, "?", sChr)
   sName = Replace(sName, Chr(34), sChr) ' quotation
   sName = Replace(sName, Chr(32), sChr) ' space
   sName = Replace(sName, "<", sChr)
   sName = Replace(sName, ">", sChr)
   sName = Replace(sName, "|", sChr)
   sName = Replace(sName, ")", sChr)
   sName = Replace(sName, "(", sChr)
   sName = Replace(sName, "-", sChr)
   sName = Replace(sName, "&", sChr)
   sName = Replace(sName, "~", sChr)

   sName = Replace(sName, "+", sChr)
   sName = Replace(sName, "!", sChr)
   sName = Replace(sName, "@", sChr)
   sName = Replace(sName, "#", sChr)
   sName = Replace(sName, "$", sChr)
   sName = Replace(sName, "%", sChr)
   sName = Replace(sName, "^", sChr)
   sName = Replace(sName, "*", sChr)
   sName = Replace(sName, "|", sChr)
   sName = Replace(sName, "]", sChr)
   sName = Replace(sName, "[", sChr)
   sName = Replace(sName, "{", sChr)
   sName = Replace(sName, "}", sChr)
   sName = Replace(sName, ",", sChr)
   sName = Replace(sName, ";", sChr)

   sName = Replace(sName, "`", sChr)
   sName = Replace(sName, "=", sChr)

   sName = Replace(sName, Chr(145), sChr) ' smart quotes
   sName = Replace(sName, Chr(146), sChr)
   sName = Replace(sName, Chr(147), sChr)
   sName = Replace(sName, Chr(148), sChr)

   sName = Replace(sName, "__", "_")
   sName = Replace(sName, "__", "_")
   sName = Replace(sName, "__", "_")

End Sub