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