Save weekly email attachments in an Outlook folder to hard drive

Question

I coded a macro that will save the attachments in an Outlook folder (Style Transfers) to a folder on my hard drive (desktop).

It will save all the attachments located in the Outlook folder. I need to save only current week email attachments.

Option Explicit
Const folderPath = "C:\Users\dilshanra\Desktop\Style Transfers\"

Sub Saveattachments()
On Error Resume Next
Dim ns As NameSpace
Set ns = GetNamespace("MAPI")
Dim Inbox As MAPIFolder
Set Inbox = ns.GetDefaultFolder(olFolderInbox)

Dim searchFolder As String
searchFolder = InputBox("What is your subfolder name?")

Dim subFolder As MAPIFolder

Dim Item As Object
Dim Attach As Attachment
Dim FileName As String
Dim i As Integer

If searchFolder <> "inbox" Then
    Set subFolder = Inbox.Folders(searchFolder)
    i = 0
    If subFolder.Items.Count = 0 Then
        MsgBox "There are no messages in the Inbox.", vbInformation, _
          "Nothing Found"
        Exit Sub
    End If
    For Each Item In subFolder.Items
        For Each Attach In Item.Attachments
            Attach.SaveAsFile (folderPath & Attach.FileName)
            i = i + 1
        Next Attach
    Next Item

Else
    i = 0
    If Inbox.Items.Count = 0 Then
        MsgBox "There are no messages in the Inbox.", vbInformation, _
          "Nothing Found"
        Exit Sub
    End If
    On Error Resume Next
    For Each Item In Inbox.Items
        For Each Attach In Item.Attachments
            FileName = folderPath & Attach.FileName
            Attach.SaveAsFile FileName
            i = i + 1
        Next Attach
    Next Item
End If

End Sub

Incorporate an `If DateDiff("d", Item.SentOn, Now) <= 7 Then` catch into the function — Tragamor, Apr 27 '21 at 12:35
@Tragamor Hi, Where should I insert the IF condition? Please help — Phil Smith, Apr 28 '21 at 07:10

score 0 · Answer 1 · answered Apr 27 '21 at 15:57

Iterating over all items in a folder is not really a good idea:

For Each Item In subFolder.Items
  For Each Attach In Item.Attachments

Instead, you need to use the Find/FindNext or Restrict methods of the Items class to find items that correspond to your search criteria. Here are the steps required to get the job done correctly:

First, you need to modify the search condition to get mail items for a specific time frame.

DateToCheck = "[RecievedTime] >= """ & DateStart & """"

Feel free to expand the search criteria according to your needs.

Second, you need to iterate over all items found in the loop, not just get the first and process attachments (VBA syntax):

Set myRestrictItems = myContacts.Restrict(DateToCheck)  
For Each myItem In myRestrictItems  
    If (myItem.Class = olMail) Then  
       MsgBox myItem.Subject & ": " & myItem.RecievedTime
    End If  
Next

The MailItem.ReceivedTime property returns a Date indicating the date and time at which the item was received.

Third, here is the search query for items with attachments (VBA syntax):

query ="@SQL=" & chr(34) & "urn:schemas:httpmail:hasattachment" & chr(34) & "=True"

or

query ="@SQL=" & chr(34) & "urn:schemas:httpmail:hasattachment" & chr(34) & "=1"

You can read more about Find/FindNext or Restrict methods in the following articles:

score 0 · Answer 2 · answered Feb 03 '22 at 14:01

Misuse of On Error Resume Next = Do not allow debugging.

VBA: How long does On Error Resume Next work?

How to return blank or zero when 'On Error Resume Next' leaves previous value in variable?

Option Explicit

Const folderPath = "C:\Users\dilshanra\Desktop\Style Transfers\"

Sub Saveattachments()

Dim Inbox As Folder
Set Inbox = Session.GetDefaultFolder(olFolderInbox)

Dim inputBoxMsg As String
inputBoxMsg = "What is your folder name (not case-sensitive)?" & vbCr & vbCr & _
  "Inbox or folder one level below Inbox."

Dim searchFolder As String
searchFolder = InputBox(inputBoxMsg, , "Inbox")

Dim myFolder As Folder

Dim Item As Object
Dim Attach As Attachment
Dim FileName As String

If LCase(searchFolder) <> LCase("Inbox") Then

    ' Bypass expected error when the folder cannot be found.
    On Error Resume Next
    Set myFolder = Inbox.Folders(searchFolder)
    ' Limit error bypass to the least number of lines possible.
    On Error GoTo 0
    
    If myFolder Is Nothing Then
        Debug.Print "Folder not found under Inbox: " & searchFolder
        MsgBox "Folder not found under Inbox: " & searchFolder
        Exit Sub
    End If
    
    saveFromFolder myFolder
    
Else
    Set myFolder = Inbox
    saveFromFolder myFolder
    
End If

End Sub


Private Sub saveFromFolder(myFolder As Folder)

    Dim fldrItems As Items
    
    Dim i As Long
    Dim j As Long
    
    Dim myItem As Object
    Dim Attach As Attachment
    Dim FileName As String
    
    Dim userErrMsg As String
    
    ' Could ".Restrict" to the applicable recent mailitems with attachments.
    
    ' This less efficient approach should be fast enough in this case,
    '  if the folder has a "reasonable" number of recently received items.
    
    'Sort collection of items newest to oldest. Exit when the first older mail is found.
    Set fldrItems = myFolder.Items
    fldrItems.Sort "[ReceivedTime]", True

    i = 0
    j = 0
    
    For Each myItem In fldrItems
    
        'Ensure item is a mailitem before attempting to return mailitem properties
        If TypeOf myItem Is MailItem Then
            
            ' ReceivedTime is usually a better match for incoming mail
            Debug.Print DateDiff("d", myItem.ReceivedTime, Now) & " days old. ", myItem.ReceivedTime
            If DateDiff("d", myItem.ReceivedTime, Now) <= 7 Then
    
                Debug.Print myItem.ReceivedTime, myItem.Subject
                For Each Attach In myItem.Attachments
                
                    i = i + 1
                    
                    'Bypass expected error when the attachment cannot be saved.
                    'Test with a valid example without On Error Resume Next
                    ' to not bypass an unexpected error, for example a syntax error.
                    On Error Resume Next
                    Attach.SaveAsFile (folderPath & Attach.FileName)
                    
                    Debug.Print " FileName: " & Attach.FileName
                    
                    If err <> 0 Then
                        userErrMsg = "  Error attempting to save attachment to " & folderPath
                        userErrMsg = userErrMsg & vbCr & "   " & err.Number & vbTab & err.Description
                        
                        Debug.Print userErrMsg
                        'MsgBox userErrMsg
                        
                        i = i - 1
                        j = j + 1
                    End If
                    
                    'Limit error bypass to the least number of lines possible.
                    'The debugger will advise you of subsequent unexpected errors
                    . so you can fix them.
                    On Error GoTo 0
                    
                Next Attach
                
            Else
                
                ' Exit to not process all items in the folder
                Debug.Print myItem.ReceivedTime, myItem.Subject
                Debug.Print " Exiting on old mail."
                Exit For
                    
            End If
        End If
        
    Next myItem
    
    userErrMsg = i & " attachments saved."
    userErrMsg = userErrMsg & vbCr & j & " errors / attachments not saved."
    Debug.Print userErrMsg
    MsgBox userErrMsg
    
End Sub

Save weekly email attachments in an Outlook folder to hard drive

2 Answers2