Outlook AutoSave Attachments | VBA Macro #22

Share on facebook
Share on twitter
Share on linkedin
Do you frequently receive email attachments that need to be saved to your computer? Wouldn’t it be nice if these attachments were automatically saved without having to interact with them? Cool thing is there are multiple ways to do this with VBA! This Outlook macro gives you a variety of options to automatically save email attachments. It can find attachments in the emails you select or by looping through your entire inbox. You can even set up this macro to check for attachments when emails are received. If any attachments are found they will be saved to the Folder Path you identify. By Default, the email attachments will be saved to a new Attachments folder on your desktop. If the Attachments folder doesn’t exist one will be created. This Outlook macro will save all email attachments it finds but you can limit this by customizing the VBA code to look for a specific Sender, a set Category, certain words in the Subject, or by File Type Extension. If you don’t want VBA to be checking every email that comes to your inbox you can run this macro on command saving attachments from selected email or searching your inbox. To take things to the next level leverage the Call Action from the Outlook Calendar Reminder Macros to automatically run this macro reoccurring from your Outlook calendar.

See it in Action!

Watch this video to see this macro in action.

The Code

Here is the code for this macro. Make sure the following References are setup before running it: Visual Basic For Applications, Microsoft Outlook 16.0 Object Library, Microsoft Forms 2.0 Object Library

This code will look at the emails you have selected and find attachments to save
'Leverage & Lean "Less Clicks, More Results"
Sub AutoSaveAttachmentsSelection()
' Means variable is in use
Dim Attachments As Outlook.Attachments '
Dim AttachmentsCount As Integer '
Dim Email As Outlook.MailItem '
Dim FolderObj As Object '
Dim FolderPath As String '
Dim i As Long '
Dim OutlookApp As Outlook.Application '
Dim Selection As Outlook.Selection
Dim User As String '
 
On Error GoTo LeverageLean

User = (Environ$("Username")) 'Identify Username
FolderPath = "C:\Users\" & User & "\Desktop\Attachments" 'Default create Attachments Folder on Desktop. You can update the FolderPath to somewhere else.

Set FolderObj = CreateObject("Scripting.FileSystemObject")
If FolderObj.FolderExists(FolderPath) Then 'The Folder has been found
Else: FolderObj.CreateFolder (FolderPath) 'The Folder has been created
End If
 
Set OutlookApp = Outlook.Application
Set Selection = OutlookApp.ActiveExplorer.Selection 'Determine what emails are selected

AttachmentsCount = 0 'Track how many Attachments are saved

For Each Email In Selection
'If Email.SenderEmailAddress = "" Or Email.Categories = "" Or Email.Subject = "" Or InStr(1, Email.Subject, "Search for Text") > 1 Then
Set Attachments = Email.Attachments
For i = Attachments.Count To 1 Step -1
'If InStr(1, Attachments.Item(i).Filename, "File Type Extension") > 1 Then 'Check File Type before saving
Attachments.Item(i).SaveAsFile FolderPath & "\" & Format(Date, "MM.DD.YYYY") & "-" & Format(Time, "hhmm") & "_" & Attachments.Item(i).Filename 'Save attachment to the Folder Path
AttachmentsCount = AttachmentsCount + 1
'End If
Next i
'End If
Next

If AttachmentsCount > 0 Then
MsgBox "Email Attachment(s) have been saved to the Attachments folder on your Desktop."
ElseIf AttachmentsCount = 0 Then
MsgBox "No Email Attachment(s) were found to save."
End If

Set Attachments = Nothing
Set Email = Nothing
Set FolderObj = Nothing
Set OutlookApp = Nothing
Set Selection = Nothing

Exit Sub

LeverageLean:
MsgBox (Err.Number & " - " & Err.Description & vbNewLine & vbNewLine & "Don't hesitate to email me: brentschneider@leveragelean.com")
  
End Sub
'Stay Awesome
This code will loop the emails your inbox and find attachments to save
'Leverage & Lean "Less Clicks, More Results"
Sub AutoSaveAttachmentsInbox()
' Means variable is in use
Dim Attachments As Outlook.Attachments '
Dim AttachmentsCount As Integer '
Dim CurrentEmail As Integer '
Dim Email As Outlook.MailItem '
Dim FolderObj As Object '
Dim FolderPath As String '
Dim i As Long '
Dim OutlookApp As Outlook.Application '
Dim OutlookNS As Outlook.NameSpace '
Dim StartFolder As Outlook.MAPIFolder '
Dim StartFolderItems As Outlook.Items '
Dim User As String '
 
On Error GoTo LeverageLean

User = (Environ$("Username")) 'Identify Username
FolderPath = "C:\Users\" & User & "\Desktop\Attachments" 'Default create Attachments Folder on Desktop. You can update the FolderPath to somewhere else.

Set FolderObj = CreateObject("Scripting.FileSystemObject")
If FolderObj.FolderExists(FolderPath) Then 'The Folder has been found
Else: FolderObj.CreateFolder (FolderPath) 'The Folder has been created
End If
 
Set OutlookApp = Outlook.Application
Set OutlookNS = OutlookApp.GetNamespace("MAPI")
Set StartFolder = OutlookNS.GetDefaultFolder(olFolderInbox) 'Default Outlook Account's Inbox
'Set StartFolder = OutlookNS.Folders("ACCOUNT NAME").Folders("Inbox") 'Different Outlook Account's Inbox
Set StartFolderItems = StartFolder.Items

AttachmentsCount = 0 'Track how many Attachments are saved

For CurrentEmail = StartFolderItems.Count To 1 Step -1 'Loop through emails in Start Folder
Set Email = StartFolderItems(CurrentEmail)
'If Email.SenderEmailAddress = "" Or Email.Categories = "" Or Email.Subject = "" Or InStr(1, Email.Subject, "Search for Text") > 1 Then
Set Attachments = Email.Attachments
For i = Attachments.Count To 1 Step -1
'If InStr(1, Attachments.Item(i).Filename, "File Type Extension") > 1 Then 'Check File Type before saving
Attachments.Item(i).SaveAsFile FolderPath & "\" & Format(Date, "MM.DD.YYYY") & "-" & Format(Time, "hhmm") & "_" & Attachments.Item(i).Filename 'Save attachment to the Folder Path
AttachmentsCount = AttachmentsCount + 1
'End If
Next i
'End If
Next

If AttachmentsCount > 0 Then
MsgBox "Email Attachment(s) have been saved to the Attachments folder on your Desktop."
ElseIf AttachmentsCount = 0 Then
MsgBox "No Email Attachment(s) were found to save."
End If

Set Attachments = Nothing
Set Email = Nothing
Set FolderObj = Nothing
Set OutlookApp = Nothing
Set OutlookNS = Nothing
Set StartFolder = Nothing
Set StartFolderItems = Nothing

Exit Sub

LeverageLean:
MsgBox (Err.Number & " - " & Err.Description & vbNewLine & vbNewLine & "Don't hesitate to email me: brentschneider@leveragelean.com")
  
End Sub
'Stay Awesome
This code will check incoming emails and find attachments to save
'Leverage & Lean "Less Clicks, More Results"
Option Explicit
'Means variable is in use
Private WithEvents olInboxItems As Items

'___________^____________Paste to TOP of Outlook Session___________^____________

'___________v____________Paste to BOTTOM of Outlook Session___________v____________

'Leverage & Lean "Less Clicks, More Results"
Private Sub Application_Startup()
Dim OutlookNS As Outlook.NameSpace '
Set OutlookNS = Outlook.Application.GetNamespace("MAPI")
Set olInboxItems = OutlookNS.GetDefaultFolder(olFolderInbox).Items 'Default Outlook Account's Inbox
Set OutlookNS = Nothing
End Sub
Private Sub olInboxItems_ItemAdd(ByVal Item As Object)

On Error GoTo LeverageLean

If Item.Attachments.Count > 0 Then 'If an Email Attachment exist
'If Email.SenderEmailAddress = "" Or Email.Categories = "" Or Email.Subject = "" Or InStr(1, Email.Subject, "Search for Text") > 1 Then
Call AutoSaveAttachmentsEmailReceived(Item)
'End If
End If

Exit Sub

LeverageLean:
MsgBox (Err.Number & " - " & Err.Description & vbNewLine & vbNewLine & "Don't hesitate to email me: brentschneider@leveragelean.com")
  
End Sub
Sub AutoSaveAttachmentsEmailReceived(ByVal Item As Object)
' Means variable is in use
Dim Attachments As Outlook.Attachments '
Dim AttachmentsCount As Integer '
Dim FolderObj As Object '
Dim FolderPath As String '
Dim i As Long '
Dim User As String '
 
On Error GoTo LeverageLean

User = (Environ$("Username")) 'Identify Username
FolderPath = "C:\Users\" & User & "\Desktop\Attachments" 'Default create Attachments Folder on Desktop. You can update the FolderPath to somewhere else.

Set FolderObj = CreateObject("Scripting.FileSystemObject")
If FolderObj.FolderExists(FolderPath) Then 'The Folder has been found
Else: FolderObj.CreateFolder (FolderPath) 'The Folder has been created
End If

AttachmentsCount = 0 'Track how many Attachments are saved

Set Attachments = Item.Attachments
For i = Attachments.Count To 1 Step -1
'If InStr(1, Attachments.Item(i).Filename, "File Type Extension") > 1 Then 'Check File Type before saving
Attachments.Item(i).SaveAsFile FolderPath & "\" & Format(Date, "MM.DD.YYYY") & "-" & Format(Time, "hhmm") & "_" & Attachments.Item(i).Filename 'Save attachment to the Folder Path
AttachmentsCount = AttachmentsCount + 1
'End If
Next i
'End If

If AttachmentsCount > 0 Then
MsgBox "Email Attachment(s) have been saved to the Attachments folder on your Desktop."
ElseIf AttachmentsCount = 0 Then
MsgBox "No Email Attachment(s) were found to save."
End If

Set Attachments = Nothing
Set FolderObj = Nothing

Exit Sub

LeverageLean:
MsgBox (Err.Number & " - " & Err.Description & vbNewLine & vbNewLine & "Don't hesitate to email me: brentschneider@leveragelean.com")
  
End Sub
'Stay Awesome

Macro Monday

Here is the Macro Monday video this macro was featured in. Watch this video to learn how to get the most out of this macro and start using it today!

Customization

These segments of code can be customized to personalize this macro. (Regardless of what version you use)
FolderPath = “C:\Users\” & User & “\Desktop\Attachments” ‘Default create Attachments Folder on Desktop. You can update the FolderPath to somewhere else. Update the Folder Path to where you want Email Attachments to be saved
‘If Email.SenderEmailAddress = “” Or Email.Categories = “” Or Email.Subject = “” Or InStr(1, Email.Subject, “Search for Text”) > 1 Then Use criteria like this to narrow the search for attachments to save
‘If InStr(1, Attachments.Item(i).Filename, “File Type Extension”) > 1 Then ‘Check File Type before saving Restrict what attachments are saved based on their File Type Extension such as: .docx, .xlsx, .pdf, .etc

MsgBox “Email Attachment(s) have been saved to the Attachments folder on your Desktop.” AND MsgBox “No Email Attachment(s) were found to save.” These two MsgBox can be removed if you don’t want to see the result when this macro is run
Subscribe
Notify of
0 Comments
Inline Feedbacks
View all comments

First time using VBA?

The Developer Tab is an additional section of the ribbon when activated allows you access to Visual Basic in Applications like Access, Excel, Outlook, PowerPoint, Word.
Setup Now
Once the Developer Tab is available you will have the capability to update your security to allow Macros to run in the current application.
Setup Now
A sub of code is a collection of objects and variables. For the code to successfully run a library of references needs to be set.
Setup Now
Subscribe as an Insider to receive additional rights.
If you like our content and want to show your support tip us here!

Contact Us

Looking to improve your computer processes?
Leverage & Lean is here to help!

Leverage & Lean

Is focused on improving computer processes by Leveraging programming and applying Lean principles. It is our goal to make you more efficient and effective on your computer producing “Less Clicks and More Results!”