Save Outlook Attachments On Your Desktop and Import the data from attachments to Access Table

Suppose Every month or week you receive monthly or weekly reports from multiple Reps or Person. and you have to manually check all emails then open the attachments and then copy the data of attachments to single excel sheet .

I have written a small macro which check all the unread emails in inbox(or specific folder) then

look for emails with subject "Sales Report" then download the attachments to the desktop

and then import the attachments(in CSV format) to access table "Data".

Sample File 1
Sample File 2

Download Access Database

Here is the code-

Option Compare Database
Sub save_outlook_attachmnets_to_local_desktop_and_import_files_to_database()
'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()
att.SaveAsFile Filename

If Right(Filename, 3) = "CSV" Then
Call adddata(Filename)
.Fields![Records Added Date].Value = Now()
End If
.Update
End With

RefreshDatabaseWindow
Next att
' mark emails read
oitem.UnRead = False
End If
'oitem.UnRead = False
Next
'Loop
rcd.Close
MsgBox "Done"
End Sub
Sub adddata(filepath As String)
DoCmd.SetWarnings (False)
Dim sqlqry As String
sqlqry = ""
' data is table name
DoCmd.TransferText acImportDelim, "", "Data", filepath, True
' add 'Data Added Date
sqlqry = "UPDATE Data SET [Data Added Date] =# " & Now() & "# where [Data Added Date] IS nULL"
DoCmd.RunSQL sqlqry
DoCmd.SetWarnings (True)
End Sub