Microsoft Outlook is one the best email processing application used by user on daily basis. Sometimes, it is used for bulk data transfer medium. users sending bulk emails consist of lots of attached file of various extension such as excel (Microsoft Excel), word (Microsoft Word), PDF (Adobe), Text files, Images (Photoshop file) and so on. Then, it becomes very tedious job to handle large number of attachment in Microsoft Outlook. Saving bulk attachment into specific folder takes lot of productive time which definitely impact on other activities.

Using excel VBA code this task can be automate which will definitely save lot of productive hours. This, VBA code will take hardly 5 minutes to save attachment into specific folder of your Personal Computer.

Here is the code which will save email attachment to your specific folder:

Sub Save_email_attachment_to_folder()
' Author: Dreams24
' Written for VBA Tricks and tips blog

'Parameter 1 = Folder name of folder inside your Inbox e.g. Test_Folder
'Parameter 2 = File extension, "" is every file e.g. .xls, .pdf, .doc and so on.
'Parameter 3 = Save folder, "C:\Users\Dreams\Desktop\Test_Folder" or ""
'        If you use "" it will create a date/time stamped folder for you in your "Documents" folder
'        Note: If you use this "C:\Users\Dreams\Desktop\Test_Folder\" the folder must exist.

    Save_Email_Attachments_To_Folder "Test", "", "C:\Users\Dreams\Desktop\Test_Folder"
End Sub

Write Below function just below above macro:

Function Save_Email_Attachments_To_Folder(OutlookFolderInInbox As String, ExtString As String, DestFolder As String)
' Author: Dreams24
' Written for VBA Tricks and tips blog
    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 MyDocPath As String
    Dim i As Integer
    Dim wsh As Object
    Dim fs As Object
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    On Error GoTo Handle_err:

    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    Set SubFolder = Inbox.Folders(OutlookFolderInInbox)
    i = 0
    ' Check subfolder for messages and exit of none found

    If SubFolder.Items.Count = 0 Then
        MsgBox "There are no messages in this folder : " & OutlookFolderInInbox, _
               vbInformation, "Nothing Found"
        Set SubFolder = Nothing
        Set Inbox = Nothing
        Set ns = Nothing
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
        Exit Function
    End If

    'Create DestFolder when folder not exists

    If DestFolder = "" Then
        Set wsh = CreateObject("WScript.Shell")
        Set fs = CreateObject("Scripting.FileSystemObject")
        MyDocPath = wsh.SpecialFolders.Item("mydocuments")
        DestFolder = MyDocPath & "\" & Format(Now, "dd_mmm_yyyy hh_mm_ss")
        If Not fs.FolderExists(DestFolder) Then
            fs.CreateFolder DestFolder
        End If
    End If
    If Right(DestFolder, 1) <> "\" Then
        DestFolder = DestFolder & "\"
    End If
    ' Check each message for attachments and extensions
        For Each Item In SubFolder.Items
            For Each Atmt In Item.Attachments
                If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
                    FileName = DestFolder & " " & Atmt.FileName
                    Atmt.SaveAsFile FileName
                    i = i + 1
                End If
            Next Atmt
        Next Item
    ' Show this message when Finished

    If i > 0 Then
        MsgBox "Please Browse below path for your files: " _
             & DestFolder, vbInformation, "Finished!"
        MsgBox "No attached files in your mail.", vbInformation, "Finished!"
    End If

    ' Code to Release memory
    Set SubFolder = Nothing
    Set Inbox = Nothing
    Set ns = Nothing
    Set fs = Nothing
    Set wsh = Nothing
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Exit Function

    ' Code for Error Handling

    MsgBox "An unexpected error has occurred." _
        & vbCrLf & "Please note and report the following information." _
         & vbCrLf & "Macro Name: Save_email_attachment_to_folder" _
         & vbCrLf & "Error Number: " & Err.Number _
         & vbCrLf & "Error Description: " & Err.Description _
         , vbCritical, "Error!"
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Function