VBA to download attachment of all emails with same subject : Code Error-CodePudding

I'm trying to write a code which can search my outlook for specific subject email and then save its attachment in designated folder by email received date and time. But it get stuck where I search for email with specific subject. i.e. Set foundEmails = searchFolder.Items.Restrict("[Subject] = 'KSA RDC - ECOM Inventory Report'")

can someone able to help?

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

CodePudding user response：

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 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.

CodePudding user response：

I've tried below code and the code you have provided as well. But nothing is happening not even an error.


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 Items
    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] = 'Report:  KSA RDC - ECOM Inventory Report'")
    'Set foundEmails = Dim foundEmails As Items. Items.Restrict

    ' 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
            ' check if the attachment is an excel file
            If Right(attachmentName, 4) = ".xlsx" Or Right(attachmentName, 4) = ".xlsm" Then
                ' Close the embedded object if it is open
                attach.OLEFormat.Object.Close
                'Copy the attachment to the specified folder
                attach.SaveAsFile "D:\Attachment" & attachmentName & "-" & emailName & " - " & Format(receivedTime, "yyyy-mm-dd hh-mm-ss")
            End If
    Next
    Next email
End Sub