Save Outlook Attachments On Your Desktop

If you want to run a loop through all unread emails in your inbox or any specific folder and then save all attachments from each mail on to your desktop.

The below macro will save all the attachments and also will add the following information in your access table for further use-

Download Access Database

Here is the code-


Option Compare Database
Sub save_outlook_attachmnets_to_local_desktop()
'reference -> microsoft outlook
Dim oitem As Outlook.MailItem
Dim ol As Outlook.Application
Dim olns As Outlook.Namespace
Dim oinbox As Outlook.Folder
Dim att As Outlook.Attachment
Dim rcd As DAO.Recordset
Dim dir_name As String
Dim Filename As String
Set ol = New Outlook.Application
Set olns = ol.GetNamespace("MAPI")
' check the inbox folder
Set oinbox = olns.GetDefaultFolder(olFolderInbox)
'if you want to run loop in a specific folder
' Set oinbox = oinbox.Folders("Ashish")
' we will create a new directory to save the attachments
dir_name = Application.CurrentProject.Path & "\" & Format(Now(), "DD_MMM_YYYY_HH_MM_SS") & "\"
MkDir dir_name
Set rcd = CurrentDb.OpenRecordset("attachments", dbOpenDynaset)
Do Until oinbox.Items.Restrict("[UnRead] = True").Count = 0

' run loop through each unread email
For Each oitem In oinbox.Items.Restrict("[UnRead] = True")
' check for matching subject lines
If oitem.Subject = "Sales Report" Then
' run loop through each aatachments
For Each att In oitem.Attachments
Filename = ""
With rcd
.AddNew
.Fields![Subject].Value = oitem.Subject
.Fields![Sender EmailAddress].Value = oitem.SenderEmailAddress
.Fields![Received Time].Value = oitem.ReceivedTime
.Fields![Sender Name].Value = oitem.SenderName
.Fields![File Name].Value = att.Filename
' if you know your file names are unique then use this method if you are not sure,
'then we can use below two lines to give unique names to attachments at runtime
' add one more column with orginal attachment name and new attachment name
'Application.Wait (Now + TimeValue("0:00:1"))
'.Fields![Sales].Value = Format(Now(), "dd_mmm_yyyy_hh_mm_ss") & att.Filename
Filename = dir_name & "\" & att.Filename
.Fields![File Path].Value = Filename
.Fields![Saved Date].Value = Now()
.Update
End With
att.SaveAsFile Filename
RefreshDatabaseWindow
Next att
' mark emails read
oitem.UnRead = False
End If
Next
Loop
rcd.Close
End Sub

Download Access Database