Save only those Outlook Email Attachments from Inbox, which are sent by specific sender on specific dates

Question

Hi I have more than 3500 Emails in my OL Inbox. My conditions are.

1. I Want to save all attachments from some specific senders for some specifics dates as per my requirements Using Outlook VBA.

Sub Save_OutLook_Attachments_To_Folder()
Dim App As Outlook.Application
Dim MyFolder As Outlook.MAPIFolder
Dim NS As Outlook.Namespace
Dim Msg As Outlook.MailItem
Dim Attachments As Outlook.Attachments
Dim Items As Outlook.Items
Dim i As Long
Dim lngCount As Long
Dim File As String
Dim FolderPath As String
Dim Sender_Email As String ''''

Sender_Email = "someone@somewhere.com" '''''''objMail.SenderEmailAddress  ''''''
FolderPath = ThisWorkbook.Path & "\" & "\Outlook Attachments\" '''Change the Destination Folder Path
Set App = New Outlook.Application
Set NS = App.GetNamespace("MAPI")
Set MyFolder = NS.GetDefaultFolder(olFolderInbox) ''''''''''''
Set Items = MyFolder.Items
Items.Sort Property:="[ReceivedTime]", Descending:=True
FolderPath = FolderPath
For Each Msg In MyFolder.Items
If Msg.SenderEmailAddress = Sender_Email Then '''''
Set Attachments = Msg.Attachments
lngCount = Attachments.Count
End If
Next
If lngCount > 0 Then
For i = lngCount To 1 Step -1
File = Attachments.Item(i).FileName
File = FolderPath & File
Attachments.Item(i).SaveAsFile File
Next
End If
End Sub

Would appreciate if anyone can help me in this case.

Thanks in advance.

Answer 1

Instead of iterating over all items in the folder and checking the sender-related properties:

For Each Msg In MyFolder.Items
  If Msg.SenderEmailAddress = Sender_Email Then '''''

Use the Find / FindNext or Restrict methods of the Items class. In that case you will get a collection of items that correspond to the search criteria specified. You can read more about these methods in the following articles:

• How To: Use Find and FindNext methods to retrieve Outlook mail items from a folder (C#, VB.NET)
• How To: Use Restrict method to retrieve Outlook mail items from a folder

Try using the following search criteria:

criteria = "@SQL=" & Chr(34) & "urn:schemas:httpmail:senderemail" & Chr(34) & " LIKE '%" & Sender_Email & "%'"

See Filtering Items Using a String Comparison for more information.

---

Note, you can use the logical AND operator in the search string where you can combine multiple conditions. To search items for a specific date you can filter on the urn:schemas:httpmail:datereceived property. Find the sample code in the following articles:

• How To: Retrieve Outlook calendar items using Find and FindNext methods
• How To: Use Restrict method in Outlook to get calendar items

Answer 2

Here is code I use to save the attachments from e-mails I have selected. You can probably adapt to your requirements or manually filter and select the emails when you need to.

Public Sub SaveAttachmentsSelectedEmails()
    Dim olItem As Outlook.MailItem
    Dim olSelection As Outlook.Selection: Set olSelection = ActiveExplorer.Selection
    Dim FilePath As String: FilePath = Environ("USERPROFILE") & "\Documents\Documents\Attachments"

    If Dir(FilePath, vbDirectory) = "" Then
        Debug.Print "Save folder does not exist"
        Exit Sub
    End If

    For Each olItem In olSelection
        SaveAttachments olItem, FilePath, RemoveAttachments:=False
    Next olItem
End Sub

Private Function SaveAttachments(ByVal Item As Object, FilePath As String, _
    Optional Prefix As String = "", _
    Optional FileExtensions As String = "*", _
    Optional Delimiter As String = ",", _
    Optional RemoveAttachments As Boolean = False, _
    Optional OverwriteFiles As Boolean = False) As Boolean

    On Error GoTo ExitFunction

    Dim i As Long, j As Long, FileName As String, Flag As Boolean
    Dim Extensions() As String: Extensions = Split(FileExtensions, Delimiter)
    If Right(FilePath, 1) <> "\" Then FilePath = FilePath & "\"

    For j = LBound(Extensions) To UBound(Extensions)
        With Item.Attachments
            If .Count > 0 Then
                For i = .Count To 1 Step -1
                    FileName = FilePath & Prefix & .Item(i).FileName
                    Flag = IIf(LCase(Right(FileName, Len(Extensions(j)))) = LCase(Extensions(j)), True, False)
                    Flag = IIf(FileExtensions = "*" Or Flag = True, True, False)
                    If Flag = True Then
                        If Dir(FileName) = "" Or OverwriteFiles = True Then
                            .Item(i).SaveAsFile FileName
                        Else
                            Debug.Print FileName & " already exists"
                            Flag = False
                        End If
                    End If
                    If RemoveAttachments = True And Dir(FileName) <> "" And Flag = True Then .Item(i).Delete
                Next i
            End If
        End With
    Next j
    SaveAttachments = True

ExitFunction:
End Function