Save weekly outlook emails attachments in a folder to hard drive

Question

I have coded a macro that will save all the attachments in an outlook folder ( Style Transfers) to a folder on my hard drive (desktop). But in this macro, it will save all the attachments located in the outlook folder. What I need is to save only current week email attachments to my desktop folder. Any suggestions??

Here is the code I have for my VBA Macro

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
@Tragamor Hi, Where should I insert the IF condition? Please help — Phil Smith

Eugene Astafiev Eugene Astafiev · Accepted Answer · 2021-04-27T15:57:35

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:

Save weekly outlook emails attachments in a folder to hard drive

1 Answers