I need a vba code to download attachments from Outlook which are sent daily

Joined
Jan 30, 2019
Messages
2
Reaction score
0
Private Sub get_email_attchment()

Dim objOutlook, objNamespace, objFolder, colItems, objMessage, intCount, i, colFilteredItems
Dim fso, file, fld
Dim objFile, strobjfile,
Dim objInbox, strFolderName, objMailbox
Dim oMessage As Object
Dim Mydate As Date
Dim subjects, Start As String
Call TogetDate

strFolder = "C:\Desktop"
Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(strFolder)

'Move attachments in Inbox from Outlook to folder
strFolderf = "C:\"

Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objInbox = objNamespace.GetDefaultFolder(olFolderInbox)
strFolderName = objInbox.Parent
Set objMailbox = objNamespace.Folders(strFolderName)
Set objFolder = objMailbox.Folders("DAILY FILES")

On Error Resume Next

Set colItems = objFolder.Files
For Each objMessage In colItems
x = x + 1
intCount = objMessage.Attachments.Count
If intCount > 0 Then
For i = 1 To intCount
'Checks if file exists in temp folder, changes file name
strobjfile = objMessage.Attachments.Item(i).Filename
FileLastModified = fso.objMessage.Attachments.Item(i).Filename.DateLastModified
If FileDateTime(strobjfile) = Mydate Then
objMessage.Attachments.Item(i).SaveAsFile strFolder & objMessage.Attachments.Item(i).Filename
End If
Next
End If

Next
 
This above code picks up all the files that are in the folder , I want it to download only attachments that are sent today and ignore old email attachments and It will be very helpful if someone can help me to search emails based on subject, download the attachment and rename the files instantly.
 
Back
Top