Option Explicit Public Sub ExportAttachments() 'Extract attachments from outlook folder accounting for duplicates Dim objOL As Outlook.Application Dim objMsg As Object Dim objAttachments As Outlook.Attachments Dim objSelection As Outlook.Selection Dim i As Long, lngCount As Long Dim filesRemoved As String, fName As String, StrFolder As String, saveFolder As String, savePath As String Dim alterEmails As Boolean, overwrite As Boolean Dim result saveFolder = BrowseForFolder("Select the folder to save attachments to.") If saveFolder = vbNullString Then Exit Sub result = MsgBox("Do you want to remove attachments from selected file(s)? " & vbNewLine & _ "(Clicking no will export attachments but leave the emails alone)", vbYesNo + vbQuestion) alterEmails = (result = vbYes) Set objOL = CreateObject("Outlook.Application") Set objSelection = objOL.ActiveExplorer.Selection For Each objMsg In objSelection If objMsg.Class = olMail Then Set objAttachments = objMsg.Attachments lngCount = objAttachments.Count If lngCount > 0 Then filesRemoved = "" For i = lngCount To 1 Step -1 fName = objAttachments.Item(i).FileName savePath = saveFolder & "\" & fName overwrite = False While Dir(savePath) <> vbNullString And Not overwrite Dim newFName As String newFName = InputBox("The file '" & fName & _ "' already exists. Please enter a new file name, or just hit OK overwrite.", _ "Confirm File Name", fName) If newFName = vbNullString Then GoTo skipfile If newFName = fName Then overwrite = True Else fName = newFName savePath = saveFolder & "\" & fName Wend objAttachments.Item(i).SaveAsFile savePath If alterEmails Then filesRemoved = filesRemoved & "<br>""" & objAttachments.Item(i).FileName & """ (" & _ formatSize(objAttachments.Item(i).size) & ") " & _ "<a href=""" & savePath & """>[Location Saved]</a>" objAttachments.Item(i).Delete End If skipfile: Next i If alterEmails Then filesRemoved = "<b>Attachments removed</b>: " & filesRemoved & "<br><br>" Dim objDoc As Object Dim objInsp As Outlook.Inspector Set objInsp = objMsg.GetInspector Set objDoc = objInsp.WordEditor objMsg.HTMLBody = filesRemoved + objMsg.HTMLBody objMsg.Save End If End If End If Next ExitSub: Set objAttachments = Nothing Set objMsg = Nothing Set objSelection = Nothing Set objOL = Nothing End Sub Function formatSize(size As Long) As String Dim val As Double, newVal As Double Dim unit As String val = size unit = "bytes" newVal = Round(val / 1024, 1) If newVal > 0 Then val = newVal unit = "KB" End If newVal = Round(val / 1024, 1) If newVal > 0 Then val = newVal unit = "MB" End If newVal = Round(val / 1024, 1) If newVal > 0 Then val = newVal unit = "GB" End If formatSize = val & " " & unit End Function 'Function purpose: To Browser for a user selected folder. 'If the "OpenAt" path is provided, open the browser at that directory 'NOTE: If invalid, it will open at the Desktop level Function BrowseForFolder(Optional Prompt As String, Optional OpenAt As Variant) As String Dim ShellApp As Object Set ShellApp = CreateObject("Shell.Application").BrowseForFolder(0, Prompt, 0, OpenAt) On Error Resume Next BrowseForFolder = ShellApp.Self.Path On Error GoTo 0 Set ShellApp = Nothing 'Check for invalid or non-entries and send to the Invalid error handler if found 'Valid selections can begin L: (where L is a letter) or \\ (as in \\servername\sharename. All others are invalid Select Case Mid(BrowseForFolder, 2, 1) Case Is = ":": If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid Case Is = "\": If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid Case Else: GoTo Invalid End Select Exit Function Invalid: 'If it was determined that the selection was invalid, set to False BrowseForFolder = vbNullString End Function Function BrowseForFile(Optional Prompt As String, Optional OpenAt As Variant) As String Dim ShellApp As Object Set ShellApp = CreateObject("Shell.Application").BrowseForFolder(0, Prompt, 16 + 16384, OpenAt) On Error Resume Next BrowseForFile = ShellApp.Self.Path On Error GoTo 0 Set ShellApp = Nothing 'Check for invalid or non-entries and send to the Invalid error handler if found 'Valid selections can begin L: (where L is a letter) or \\ (as in \\servername\sharename. All others are invalid Select Case Mid(BrowseForFolder, 2, 1) Case Is = ":": If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid Case Is = "\": If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid Case Else: GoTo Invalid End Select Exit Function Invalid: 'If it was determined that the selection was invalid, set to False BrowseForFile = vbNullString End Function
Preview:
downloadDownload PNG
downloadDownload JPEG
downloadDownload SVG
Tip: You can change the style, width & colours of the snippet with the inspect tool before clicking Download!
Click to optimize width for Twitter