• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Save Attachment in a specific folder when mail received from a specific sender in outlook

Hii All

I have been looking for the way out wherein attachments can get saved in a folder when the mail is received from a specific sender.

The mail client is outlook 2010

Highly appreciate the help.

Regards
 
There are several things to consider when doing that. In this code, I helped another with a similar goal. Change it to suit your needs. See the first commented link for the all Outlook method.

For the other method:
1. Making an Outlook rule to move emails to a folder is for processing later.
2. Run your macro similar to my posted code.
3. Make another macro to move the files in (2) to an archive folder.

Or some variation therein.

Code:
'https://www.extendoffice.com/documents/outlook/3747-outlook-auto-download-save-attachments-to-folder.html

'or
'https://www.excelguru.ca/forums/showthread.php?9073-VBA-to-automatically-extract-email-attachments-and-save-them-into-a-specific-file

Sub SetFolder()  'Early Binding: Tools > References > Microsoft Outlook xx.0 Object Library > OK
  Dim OL As Outlook.Application
  Dim objRecipient As Outlook.Recipient, objAction As Outlook.Action
  'Dim objFolder As Outlook.MAPIFolder
  Dim objFolder As Outlook.Folder 'For Gmail Task's folder
  Set OL = CreateObject("Outlook.Application")
  'Set objFolder = OL.GetNamespace("MAPI").GetDefaultFolder(olFolderTasks) 'olFolderTasks=13
  'Set objFolder = OL.GetNamespace("MAPI").PickFolder
  'Debug.Print objFolder.Name, objFolder.FolderPath

  Set objFolder = GetFolderPath("\\Ken@gmail.com\Puppy\Pics", OL)
  Debug.Print objFolder.Name, objFolder.FolderPath
End Sub

'Similar to, http://www.slipstick.com/developer/working-vba-nondefault-outlook-folders/#GetFolderPath
''Early Binding: Tools > References > Microsoft Outlook xx.0 Object Library > OK
Function GetFolderPath(ByVal FolderPath As String, oApp As Outlook.Application) As Outlook.Folder
    Dim oFolder As Outlook.Folder
    Dim FoldersArray As Variant
    Dim i As Integer
     
    On Error GoTo GetFolderPath_Error
    If Left(FolderPath, 2) = "\\" Then
        FolderPath = Right(FolderPath, Len(FolderPath) - 2)
    End If
    'Convert folderpath to array
   FoldersArray = Split(FolderPath, "\")
    'Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
   Set oFolder = oApp.Session.Folders.Item(FoldersArray(0))
    If Not oFolder Is Nothing Then
        For i = 1 To UBound(FoldersArray, 1)
            Dim SubFolders As Outlook.Folders
            Set SubFolders = oFolder.Folders
            Set oFolder = SubFolders.Item(FoldersArray(i))
            If oFolder Is Nothing Then
                Set GetFolderPath = Nothing
            End If
        Next
    End If
    'Return the oFolder
   Set GetFolderPath = oFolder
    Exit Function
     
GetFolderPath_Error:
    Set GetFolderPath = Nothing
    Exit Function
End Function

Sub GetAttachments()
' This Outlook macro checks a the Outlook Inbox for messages
' with attached files (of any type) and saves them to disk.
' NOTE: make sure the specified save folder exists before
' running the macro.
    On Error GoTo GetAttachments_err
' Declare variables
    Dim ns As Namespace
    Dim Inbox As MAPIFolder
    Dim Item As Object
    Dim Atmt As Attachment
    Dim FileName As String
    Dim i As Integer
    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    i = 0
' Check Inbox for messages and exit of none found
    If Inbox.Items.Count = 0 Then
        MsgBox "There are no messages in the Inbox.", vbInformation, _
               "Nothing Found"
        Exit Sub
    End If
' Check each message for attachments
    For Each Item In Inbox.Items
        If Item.UnRead = True Then 'Add this for checking unread emails
            ' Save any attachments found
                    For Each Atmt In Item.Attachments
                        If (Right(Atmt.FileName, 4) = "xlsx") Or (Right(Atmt.FileName, 4) = ".xls") Then
                        ' This path must exist! Change folder name as necessary.
                            FileName = "S:\Maintenance\Test\" & _
                                Format(Item.CreationTime, "yyyymmdd_hhnnss_") & Atmt.FileName
                            Atmt.SaveAsFile FileName
                            Item.UnRead = False 'Mark email item as read
                            i = i + 1
                        End If
                Next Atmt
        End If
    Next Item
' Show summary message
    If i > 0 Then
        MsgBox "I found " & i & " attached files." _
        & vbCrLf & "I have saved them into the S:\Maintenance\Test." _
        & vbCrLf & vbCrLf & "Have a nice day.", vbInformation, "Finished!"
    Else
        MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!"
    End If
' Clear memory
GetAttachments_exit:
    Set Atmt = Nothing
    Set Item = Nothing
    Set ns = Nothing
    Exit Sub
' Handle errors
GetAttachments_err:
    MsgBox "An unexpected error has occurred." _
        & vbCrLf & "Please note and report the following information." _
        & vbCrLf & "Macro Name: GetAttachments" _
        & vbCrLf & "Error Number: " & Err.Number _
        & vbCrLf & "Error Description: " & Err.Description _
        , vbCritical, "Error!"
    Resume GetAttachments_exit
End Sub
 
Hii All

I have been looking for the way out wherein attachments can get saved in a folder when the mail is received from a specific sender.

I am using Gmail.

Regards
 
Back
Top