Outlook VBA

NotaVBAeXpert

New Member
Joined
May 4, 2018
Messages
26
Hi All,

I want to automatically download attachments I receive from work to a folder on my computer. Currently, I have it downloading everything in my inbox but I want to set parameters so it only downloads the prior weeks attachments from the current day. This is what I have so far:

Option Explicit

Sub GetAttachments()




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


If Inbox.Items.Count = 0 Then
MsgBox "There are no messages in the Inbox.", vbInformation, _
"Nothing Found"

End If


For Each Item In Inbox.Items
For Each Atmt In Item.Attachments
FileName = "C:\Users\Documents" & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
Next Atmt
Next Item


If i > 0 Then
MsgBox "I found " & i & " attached files." _
& vbCrLf & "I have saved them into the C:\Users\Documents\." _
& vbCrLf & vbCrLf & "Have a nice day.", vbInformation, "Finished!"
Else
MsgBox "I didn't find any attached files in your mail.", vbInformation, _
"Finished!"
End If
End Sub


Does anyone have any ideas on how to set those parameters and only look back a week?

Thanks!
 

Excel Facts

Which lookup functions find a value equal or greater than the lookup value?
MATCH uses -1 to find larger value (lookup table must be sorted ZA). XLOOKUP uses 1 to find values greater and does not need to be sorted.
Hi

Code:
' Outlook module
Sub GetAttachments()
Dim ns As NameSpace, Inbox As MAPIFolder, Item As Object, _
Atmt As Attachment, FileName$, i%, mi As MailItem
Const thold = 100               ' days to look back
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
i = 0
If Inbox.Items.Count = 0 Then MsgBox "There are no messages in the Inbox.", _
vbInformation, "Nothing Found"
For Each Item In Inbox.Items
    For Each Atmt In Item.Attachments
        FileName = "C:\Users\Documents\" & Atmt.FileName
        If Item.ReceivedTime > Now - thold Then
            MsgBox FileName
            'Atmt.SaveAsFile FileName
            i = i + 1
        End If
    Next
Next
If i > 0 Then
    MsgBox "I found " & i & " attached files." _
    & vbCrLf & "I have saved them into the C:\Users\Documents\." _
    & vbCrLf & vbCrLf & "Have a nice day.", 64, "Finished!"
Else
    MsgBox "I didn't find any attached files.", 64, "Finished!"
End If
End Sub
 
Upvote 0

Forum statistics

Threads
1,223,228
Messages
6,170,875
Members
452,363
Latest member
merico17

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top