How to search for emails with same subject? - excel

Question

I'm trying to search Outlook by email received date and time, for specific subject email and then save its attachment in designated folder.
It gets stuck where I search for email with specific subject.
Set foundEmails = searchFolder.Items.Restrict("[Subject] = 'KSA RDC - ECOM Inventory Report'")
Sub SearchAndDownloadAttachments()
' Declare variables for the Outlook application and folder
Dim outlookApp As Outlook.Application
Dim outlookNamespace As Namespace
Dim inboxFolder As MAPIFolder
Dim searchFolder As MAPIFolder
Dim foundEmails As Search
Dim email As Outlook.MailItem
Dim attach As Outlook.Attachment
' Set the Outlook application and namespace
Set outlookApp = New Outlook.Application
Set outlookNamespace = outlookApp.GetNamespace("MAPI")
' Set the inbox folder and search folder
Set inboxFolder = outlookNamespace.GetDefaultFolder(olFolderInbox)
Set searchFolder = inboxFolder.Folders("IT Reports")
' Search for emails with the specified subject
Set foundEmails = searchFolder.Items.Restrict("[Subject] = 'KSA RDC - ECOM Inventory Report'")
' Loop through the found emails
For Each email In foundEmails
' Declare variables for the email name and received time
Dim emailName As String
Dim receivedTime As Date
Dim attachmentName As String
' Set the email name and received time
emailName = email.SenderName
receivedTime = email.receivedTime
' Loop through the attachments of the email
For Each attach In email.Attachments
attachmentName = attach.Filename
' Copy the attachment to the specified folder
attach.SaveAsFile "C:\Attachments\" & attachmentName & "-" & emailName & " - " & Format(receivedTime, "yyyy-mm-dd hh-mm-ss")
Next
Next email
End Sub

Answer 1

Please, test the next adapted code. Take care to change the subject string, to be exactly as the one you try returning:
Sub SearchAndDownloadAttachments()
' Declare variables for the Outlook application and folder
Dim outlookApp As Outlook.Application, outlookNamespace As NameSpace
Dim inboxFolder As MAPIFolder, searchFolder As MAPIFolder
Dim foundEmails As Items, email As Outlook.MailItem
Dim attach As Outlook.Attachment
' Set the Outlook application and namespace
Set outlookApp = New Outlook.Application
Set outlookNamespace = outlookApp.GetNamespace("MAPI")
' Set the inbox folder and search folder
Set inboxFolder = outlookNamespace.GetDefaultFolder(olFolderInbox)
Set searchFolder = inboxFolder.Folders("IT Reports")
' Search for emails with the specified subject
Set foundEmails = searchFolder.Items.Restrict("[Subject] = 'KSA RDC - ECOM Inventory Report'") 'change here the exact spelled subject string!
' Loop through the found emails
For Each email In foundEmails
' Declare variables for the email name and received time
Dim emailName As String, receivedTime As Date, attachmentName As String
Dim ext As String, nameRoot As String 'new declarations
' Set the email name and received time
emailName = email.SenderName
receivedTime = email.receivedTime
' Loop through the attachments of the email
For Each attach In email.Attachments
attachmentName = attach.FileName
ext = Right(attachmentName, Len(attachmentName) - InStrRev(attachmentName, ".") + 1) 'extract extension
nameRoot = left(attachmentName, Len(attachmentName) - Len(ext)) 'the remained name (without extension)
' Copy the attachment to the specified folder
attach.SaveAsFile "C:\Attachments\" & nameRoot & "-" & emailName & " - " & _
Format(receivedTime, "yyyy-mm-dd hh-mm-ss") & ext
Next
Next email
End Sub
Your last error may be related to the fact that Outlook is not able to save a file without extension and Excel remains hanged on this Outlook attempt...
Please, send some feedback after testing the code.