VBA :Macro to Download Email Attachments

Start Outlook à
Tools à Macro à Visual Basic Editor.

Add a new code module by choosing Insert > Module and add the following code. Compile the Macro and run.

 

Sub DownloadAttachments()

Dim ns As
NameSpace

Dim Inbox As MAPIFolder

Dim Subfolder As MAPIFolder

Dim Item As
Object

Dim Atmt As Attachment

Dim FileName As
String

Dim Localfolder As
String

Dim SubfolderName As
String

 

Dim i As
Integer

Dim j As
Integer

 

'***************************

' This Macro is coded to downlaod the files only from the folders under the INBOX.

' Apprently you could change ns.GetDefaultFolder(olFolderInbox) argument to any other folder and try.

' The NameSpace is the object that gives you access to all Outlook's folders.

' In Outlook there is only one and it is called "MAPI" which is an acronym for Messaging Application Programming

'    Interface.

'***************************

On
Error
GoTo GetAttachments_err

 

Localfolder = "C:\Email Attachments\"

SubfolderName = "AppWorx"
'Configure your own folder name which is under your INBOX.

 

ns = GetNamespace("MAPI")

Inbox = ns.GetDefaultFolder(olFolderInbox) ''Change the argument to any other folder.

Subfolder = Inbox.Folders(SubfolderName)

i = 0

 

If Subfolder.Items.Count = 0 Then

MsgBox("There are no messages in the folder." _

, vbInformation, "Nothing Found")

Exit
Sub

End
If

 

If Subfolder.Items.Count > 0 Then

j = j + 1

For
Each Item In Subfolder.Items

For
Each Atmt In Item.Attachments

If LCase(Right(Atmt.FileName, 4)) = ".csv"
Then 'change your filter logi here

FileName = Localfolder & Atmt.FileName

Atmt.SaveAsFile(FileName)

i = i + 1

End
If

Next Atmt

Next Item

End
If

 

 

If i > 0 Then

varResponse = MsgBox("Downloaded " & i & " files." _

& vbCrLf & "Saved @" & Localfolder & " folder." _

& vbCrLf & vbCrLf & "Would you like to view the files now?" _

, vbQuestion + vbYesNo, "Finished!")

If varResponse = vbYes Then

Shell("Explorer.exe /e, " & Localfolder, vbNormalFocus)

End
If

Else

MsgBox("I didn't find any attached files in your mail.", vbInformation, _

"Finished!")

End
If

 

GetAttachments_exit:

Atmt = Nothing

Item = Nothing

ns = Nothing

Exit
Sub

 

GetAttachments_err:

MsgBox("An unexpected error has occurred. @" & j & "Email record" & Err.Number _

& vbCrLf & "Error Description: " & Err.Description _

, vbCritical, "Error!")

Resume GetAttachments_exit

End
Sub