Save Excel attachments from incoming emails with certain text in the subject

Question

I had been using Outlook rules to run a script if the subject contains "My Calls" to save an Excel file.

Since an update I can no longer use the "run a script" option of Outlook's rules. I haven't managed to work out the VBA to check all emails for My Calls in the subject to then run the script.

Private Sub SaveAttachments(Item As Outlook.MailItem)

If Item.Attachments.Count > 0 Then

    Dim EmAttach As Outlook.Attachments 
    Dim AttachCount As Long 
    Dim EmAttFile As String 
    Dim sFileType As String 
    Dim i As Long

    Set EmAttach = Item.Attachments AttachCount = EmAttach.Count

    For i = AttachCount To 1 Step -1

       'Get the file name. 
        EmAttFile = EmAttach.Item(i).FileName

        If LCase(Right(EmAttFile, 5)) = ".xlsx" Then

            'Get the path to your My Documents folder 
            DestFolderPath = CreateObject("WScript.Shell").SpecialFolders(16) DestFolderPath = DestFolderPath & "\Attachments"

            'Combine with the path to the folder. 
            EmAttFile = DestFolderPath & EmAttFile

            'Save the attachment as a file. 
             EmAttach.Item(i).SaveAsFile EmAttFile 
         End If 
     Next i 
End If

End Sub

I need this code to work automatically. I receive 35+ spreadsheets with a list of calls that an agent has completed. These have to be saved in a fixed location (they don't have access to) so another sheet can extract the data into a dashboard.

Does this throw an error? If so, what is the error message and on what line? — BigBen, Nov 09 '20 at 17:50
there is no error, i just dont how to make it start automatically when an email with "My Calls" is in the subject, it worked fine with the Outlook rule to run a script, however i can no longer use this as its been removed. — Daniel Barker, Nov 09 '20 at 17:54
[How to restore missing Run a script option in Outlook rule](https://www.extendoffice.com/documents/outlook/4640-outlook-rule-run-a-script-missing.html#:~:text=Restore%20missing%20Run%20a%20script%20option%20in%20Outlook,QWORD%20Value%20dialog%20box.%20See%20screenshot%3A%20More%20items) — 0m3r, Nov 09 '20 at 22:49
Does this answer your question? [How do I trigger a macro to run after a new mail is received in Outlook?](https://stackoverflow.com/questions/11263483/how-do-i-trigger-a-macro-to-run-after-a-new-mail-is-received-in-outlook) — niton, Feb 03 '22 at 12:49

Tragamor · Answer 1 · 2020-11-10T11:57:00.743

So I recently wanted to automate some pdf attachments saves along similar lines to what you want to achieve. The way I set it up was to have a subfolder that I could apply a filter rule to incoming e-mails to segregate the e-mails I want to pull the pdf's from into this folder. With VBA you can pickup the new e-mails and process the attachments.

The following code is what I currently use so would need to be adapted for use, but shows the general approach

Within the 'ThisOutlookSession' module

Private WithEvents ReportItems As Outlook.Items

Private Sub Application_Startup()
    On Error Resume Next
    With Outlook.Application
        Set ReportItems = .GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("PDFData").Items
    End With
End Sub

Private Sub ReportItems_ItemAdd(ByVal Item As Object)
    On Error Resume Next
    If TypeName(Item) = "MailItem" Then Call SavePDFAttachmentReports(Item, "C:\Reports")
End Sub

Within a module

Sub SavePDFAttachmentReports(ByVal Item As Object, FilePath As String)
    Dim i As Long, FileName As String
    If Right(FilePath, 1) <> "\" Then FilePath = FilePath & "\"
    
    With Item.Attachments
        If .Count > 0 Then
            For i = 1 To .Count
                FileName = FilePath & .Item(i).FileName
                If LCase(Right(FileName, 3)) = "pdf" Then
                    FileName = Left(FileName, Len(FileName) - 4) & " Reverse Phase Report.pdf"
                    .Item(i).SaveAsFile FileName
                End If
            Next i
        End If
    End With
End Sub

Adapted (untested):

Private WithEvents ReportItems As Outlook.Items

Private Sub Application_Startup()
    On Error Resume Next
    With Outlook.Application
        Set ReportItems = .GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("Excel Reports").Items
    End With
End Sub

Private Sub ReportItems_ItemAdd(ByVal Item As Object)
    On Error Resume Next
    If TypeName(Item) = "MailItem" Then Call _
        SaveXLSXAttachments(Item, Environ("USERPROFILE") & "\My Documents\Attachments")
End Sub

Sub SaveXLSXAttachments(ByVal Item As Object, FilePath As String)
    Dim i As Long, FileName As String
    If Right(FilePath, 1) <> "\" Then FilePath = FilePath & "\"

    With Item.Attachments
        If .Count > 0 Then
            For i = 1 To .Count
                FileName = FilePath & .Item(i).FileName
                'Debug.Print FileName
                If LCase(Right(FileName, 5)) = ".xlsx" Then .Item(i).SaveAsFile FileName
            Next i
        End If
    End With
End Sub

thanks for the your help i have tried to implement the above code and am not sure why it is not working. I have created a rule to move any incoming emails with "my calls" in the subject to the Excel reports folder however the code doesnt seem to be saving the files down. sorry still new to VBA — Daniel Barker, Nov 10 '20 at 09:36
A few things: check capitalisation of 'Excel Reports' match for both the Folder and in the code. I also found that trying to save to \My Documents\Attachments didn't work quite correctly as the folder didn't appear to exist on my PC but when I tried to add them, then they did? I altered it to "\Documents\Documents\Attachments" then the file saved so check the FilePath of the folder you want to save in matches the FilePath in the code. You can for example add 'Debug.Print FileName' within the code to check the code is being called and that the filename matches what you expect. — Tragamor, Nov 10 '20 at 11:53
Oh - also Outlook VBA sometimes just stops working (usually when you have altered code or had an error). You may need to close Outlook and reopen to reinitialise the VBA — Tragamor, Nov 10 '20 at 12:01

Save Excel attachments from incoming emails with certain text in the subject

1 Answers1