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