Extract attachments from outlook folder (Accounting for duplicates) (Public)
Fri Aug 06 2021 06:58:27 GMT+0000 (UTC)
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
Comments