Outlook Save-Attachments macro

With all props and credit to ArcaneCode, I post here a fork of his save-attachments macro.  My needs were a bit different from ArcaneCode’s so I made some substantial modifications.

Specifically,

  • I want there to be an attachment in my email or calendar item so I can find it using “hasattachments:yes” in my search terms.
  • I want to have a link from the email to the attachment (as well as a link to the containing folder)
  • I don’t want to specify the folder each time I save attachments, so I have a variable that puts them under a root folder specified in the script in a sub-folder named sender/subject/date
  • I had to address long subject lines and long attachment names by truncating carefully, and removing characters that don’t work well in the on-disk folders.
  • It removes *all* attachments, even signature line icons and the like.  Usually small files are not things I’d care to click on, so I included a file-size indicator in the link to help me figure out which were window dressing and which were probably screenshots or other large pastings from the sender.

Make sure to add the “Microsoft Scripting Runtime” in your Tools-References in the macro editor.  Also be sure to set the root folder and micro-file attachment path.  I just used a completely empty notepad.exe file.

I left a lot of the original stuff in there, so it’s not exactly tidy, but it works reliably.

Public Sub SaveAttachments()
   ‘Note, this assumes you are in the a folder with e-mail messages when you run it.
   ‘It does not have to be the inbox, simply any folder with e-mail messages
  
  Dim App As New Outlook.Application
   Dim Exp As Outlook.Explorer
   Dim Sel As Outlook.Selection
  
  Dim AttachmentCnt As Integer
   Dim AttTotal As Integer
   Dim MsgTotal As Integer
      
    Dim EmptyAttachment As String
    Dim RootDirectory As String
   
  Dim outputDir As String
   Dim outputFile As String
   Dim fileExists As Boolean
   Dim cnt As Integer
  
  ‘Requires reference to Microsoft Scripting Runtime (SCRRUN.DLL)
   Dim fso As FileSystemObject
‘**************************************************************************************************
‘********   DEFAULTS  *****************************************************************************
‘**************************************************************************************************

RootDirectory = “C:\Users\<<USERNAME>>\Documents\Mail Attachments”

‘Note that the EmptyAttachment file needs to exist.  Just create a new text file and save it empty.

EmptyAttachment = “C:\Temp\Empty Attachment.txt”

‘**************************************************************************************************
‘**************************************************************************************************
    
  Set Exp = App.ActiveExplorer
   Set Sel = Exp.Selection
   Set fso = New FileSystemObject
  
    
  ‘Loop thru each selected item in the inbox
   For cnt = 1 To Sel.Count
    
     ‘If the e-mail has attachments…
     If Sel.Item(cnt).Attachments.Count > 0 Then

        MsgTotal = MsgTotal + 1
       
        outputDir = GetOutputDirectory(RootDirectory, Sel.Item(cnt))
      
       ‘For each attachment on the message…
        For AttachmentCnt = 1 To Sel.Item(cnt).Attachments.Count
        ‘Get the attachment
        Dim att As Attachment
        Set att = Sel.Item(cnt).Attachments.Item(AttachmentCnt)
        outputFile = att.FileName
       
        If Len(outputDir) + Len(outputFile) > 254 Then
            If Len(outputFile) > 64 Then
‘This part really should search for the last period in the filename to attach
‘a file extension suffix that may be longer than 3 chars, such as .config.  But I’m not bothering with that right now.

‘also note that there is logic in the “GetOutputDirectory” function that has to match these settings, such as folder length 184 and filename length 55
            FullFolderPath = Left(outputDir, 184) + “(…)\”
            FullFilePath = FullFolderPath + Left(outputFile, 55) + “(…)” + Right(outputFile, 4)
            Else
                FullFolderPath = Left(outputDir, 254 – Len(outputFile) – 6) + “(…)\”
                FullFilePath = FullFolderPath + outputFile
            End If
        Else
            FullFolderPath = outputDir
            FullFilePath = outputDir + outputFile
        End If
       
        FullFilePath = Replace(FullFilePath, “>”, “”)
        fileExists = fso.fileExists(FullFilePath)
        
        Do While fileExists = True
            outputFile = InputBox(“The file ” + outputFile _
             + ” already exists in the destination directory of ” _
             + outputDir + “. Please enter a new name, or hit cancel to skip this one file.”, “File Exists”, outputFile)
            ‘If user hit cancel
            If outputFile = “” Then
                ‘Exit leaving fileexists true. That will be a flag not to write the file
                Exit Do
            End If
            fileExists = fso.fileExists(FullFilePath)
        Loop
        
        ‘Save it to disk if the file does not exist
        If fileExists = False Then
           
            att.SaveAsFile FullFilePath
            FileSize = CStr(Int(att.Size / 1024 / 1024)) + “.” + Right(“00” + (CStr(Int(((att.Size / 1024 / 1024) – Int(att.Size / 1024 / 1024)) * 100))), 2)
            If Sel.Item(cnt).Class = olMail Then
                If Sel.Item(cnt).BodyFormat = olFormatHTML Or Sel.Item(cnt).BodyFormat = olFormatRichText Then
                    Dim BodyStart As Integer
   
                    ‘The following lines are for debugging, to allow inspection of the raw content of an HTML or Rich Text email
                    ‘Content Before:
                    ‘                Dim FileObject As File
                    ‘                Dim Stream As TextStream
                    ‘                Set Stream = fso.CreateTextFile(“c:\temp\test.txt”, True)
                    ‘                Stream.Write (Sel.Item(cnt).HTMLBody)
                   
                    ‘Make the change to the body
                   
                    BodyStart = InStr(1, Sel.Item(cnt).HTMLBody, “<Body”, vbTextCompare)
                    Sel.Item(cnt).HTMLBody = Mid(Sel.Item(cnt).HTMLBody, 1, BodyStart) + Replace(Sel.Item(cnt).HTMLBody, “>”, “>Attachment Saved to <A HREF=””file:///” + FullFolderPath + “””>(.)\</A><A HREF=””file:///” + FullFilePath + “””>” + outputFile + ” (” + CStr(FileSize) + “MB)” + “</A><BR/>”, BodyStart + 1, 1, vbTextCompare)
   
                    ‘Content After
                    ‘                Stream.Write (Sel.Item(cnt).HTMLBody)
                    ‘                Stream.Close
                    ‘               Sel.Item(cnt).Save
                End If
           
                If Sel.Item(cnt).BodyFormat = olFormatPlain Then
                    Sel.Item(cnt).Body = “Attachment Saved to “”HYPERLINK “”” + FullFolderPath + “””(.)\””file:///” + FullFilePath + “””” + ” (” + CStr(FileSize) + “MB)” + vbCrLf + Sel.Item(cnt).Body
                End If
            Else
                Sel.Item(cnt).Body = “Attachment Saved to “”HYPERLINK “”” + FullFolderPath + “””(.)\””file:///” + FullFilePath + “””” + ” (” + CStr(FileSize) + “MB)” + vbCrLf + Sel.Item(cnt).Body
            End If ‘ if item.class = olMail
            AttTotal = AttTotal + 1

         End If

       Next ‘ Attachment

‘Remove all attachments
        While Sel.Item(cnt).Attachments.Count > 0
            Set att = Sel.Item(cnt).Attachments(1)
            att.Delete
        Wend

        If Sel.Item(cnt).Class = olMail Or Sel.Item(cnt).Class = olAppointment Then
            Dim oItem As Object
           
            Set oItem = Sel.Item(cnt)
            oItem.Attachments.Add (EmptyAttachment)
        End If
       
     End If ‘ There are attachments
    
   Next ‘ Selected Item
  
  ‘Clean up
    Set Sel = Nothing
    Set Exp = Nothing
    Set App = Nothing
    Set fso = Nothing
    Set att = Nothing
    Set oItem = Nothing
    ‘Let user know we are done
‘    Dim doneMsg As String
‘   doneMsg = “Completed saving ” + Format$(AttTotal, “#,0″) + ” attachments in ” + Format$(MsgTotal, “#,0″) + ” Messages.”
‘   MsgBox doneMsg, vbOKOnly, “Save Attachments”
  
    Exit Sub
  
ErrorHandler:
   Dim errMsg As String
   errMsg = “An error has occurred. Error ” + Err.Number + ” ” + Err.Description
   Dim errResult As VbMsgBoxResult
   errResult = MsgBox(errMsg, vbAbortRetryIgnore, “Error in Save Attachments”)
   Select Case errResult
     Case vbAbort
       Exit Sub
      
    Case vbRetry
       Resume
      
    Case vbIgnore
       Resume Next
      
  End Select
    
End Sub
 ‘Found this code in a google groups thread here:
 ‘http://groups.google.com/group/microsoft.public.scripting.vbscript/browse_thread/thread/7187886c3c83a570/c278a2753e9e7ceb%23c278a2753e9e7ceb
 ‘or http://shrinkster.com/l0v
 Public Function GetOutputDirectory(RootDirectory As String, oItem As Object) As String

 

‘Code to prompt user to browse for folder has been commented out.
‘In exchange, the mail object is parsed, and the folder is created from SenderName/Subject/DateTime

 
‘  Dim retval As String ‘Return Value
  
‘  Dim sMsg As String
‘   Dim cBits As Integer
‘   Dim xRoot As Integer
   
 
‘  Dim oShell As Object
‘   Set oShell = CreateObject(“shell.application”)
‘   sMsg = “Select a Folder To Output The Attachments To”
‘   cBits = 1
‘   xRoot = 17
  
‘  On Error Resume Next
‘       Dim oBFF
‘       Set oBFF = oShell.BrowseForFolder(0, sMsg, cBits, xRoot)
‘       If Err Then
‘         Err.Clear
‘         GetOutputDirectory = “”
‘         Exit Function
‘       End If
‘   On Error GoTo 0
  
‘  If Not IsObject(oBFF) Then
‘     GetOutputDirectory = “”
‘     Exit Function
‘   End If
  
‘  If Not (LCase(Left(Trim(TypeName(oBFF)), 6)) = “folder”) Then
‘     retval = “”
‘   Else
‘     retval = oBFF.self.Path
    
    ‘Make sure there’s a \ on the end
‘     If Right(retval, 1) <> “\” Then
‘       retval = retval + “\”
‘     End If
‘   End If

  
    Dim oFSO As FileSystemObject
    Dim FolderName As String
   
    Set oFSO = New FileSystemObject
   
    ‘Quickly check for the attachment with the longest name
    For i = 1 To oItem.Attachments.Count
        If Len(oItem.Attachments(i).FileName) > LongestFileName Then
            LongestFileName = Len(oItem.Attachments(i).FileName)
        End If
    Next
   
    FolderName = RootDirectory
   
    If Not oFSO.FolderExists(FolderName) Then
        oFSO.CreateFolder (FolderName)
    End If
 
If oItem.Class = olMail Then
    FolderName = FolderName + “\” + oItem.SenderName
Else
    If oItem.Class = olAppointment Then
        FolderName = FolderName + “\” + oItem.Organizer
    End If
End If

If Not oFSO.FolderExists(FolderName) Then
    oFSO.CreateFolder (FolderName)
End If

‘Certain characters that are just fine in subject lines are problematic for filesystem folder names
‘Remove them
‘(I know there’s a better way to do this, but I’ll leave that for someone else to enhance)

    Dim Subject
    Subject = Replace(oItem.Subject, “RE:”, “”, 1, -1, vbTextCompare)
    Subject = Replace(Subject, “FW:”, “”, 1, -1, vbTextCompare)
    Subject = Replace(Subject, “”””, “”, 1, -1, vbTextCompare)
    Subject = Replace(Subject, “:”, “”, 1, -1, vbTextCompare)
    Subject = Replace(Subject, “/”, “”, 1, -1, vbTextCompare)
    Subject = Replace(Subject, “?”, “(q)”, 1, -1, vbTextCompare)
    Subject = Replace(Subject, “*”, “”, 1, -1, vbTextCompare)
    Subject = Replace(Subject, “>”, “”, 1, -1, vbTextCompare)
    Subject = Replace(Subject, “<“, “”, 1, -1, vbTextCompare)
    Subject = Replace(Subject, “.”, “”, 1, -1, vbTextCompare)
    Subject = LTrim(RTrim(Subject))

    FolderName = FolderName + “\” + Subject
   
    ‘Limit total length to 254, but remember to leave 22 characters for the datetime segment of the folder path
   
    If Len(FolderName) + LongestFileName > 254 – 22 Then
        If Len(LongestFileName) > 64 Then
‘This part really should search for the last period in the filename to attach
‘a file extension suffix that may be longer than 3 chars, such as .config.  But I’m not bothering with that right now.
‘also note that there is logic in the main function that has to match these settings, such as folder length 184 and filename length 55
        FolderName = Left(outputDir, 184)
        Else
            FolderName = Left(FolderName, 254 – 22 – LongestFileName – 6) + “(…)”
        End If
    End If
   
   
    If Not oFSO.FolderExists(FolderName) Then
        oFSO.CreateFolder (FolderName)
    End If

‘Remove colons and slashes in DateTime
    If oItem.Class = olMail Then
        FolderName = FolderName + “\” + Replace(Replace(oItem.ReceivedTime, “/”, “-“, 1, -1, vbTextCompare), “:”, “.”, 1, -1, vbTextCompare)
    Else
        If oItem.Class = olAppointment Then
            FolderName = FolderName + “\” + Replace(Replace(oItem.Start, “/”, “-“, 1, -1, vbTextCompare), “:”, “.”, 1, -1, vbTextCompare)
        End If
    End If
   
    If Not oFSO.FolderExists(FolderName) Then
        oFSO.CreateFolder (FolderName)
    End If
   
    GetOutputDirectory = FolderName + “\”
  
End Function

 

Advertisements
This entry was posted in Uncategorized. Bookmark the permalink.

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s