How to automatically save attachments from Outlook? - vba

Question

I am trying to automatically save all attachments from emails with a certain subject line to a folder. I have tried implementing multiple solutions from other questions on SO and other sources but they don't work.
I'm generally trying to follow the process outlined here: https://windowsreport.com/outlook-rule-download-attachments/
I have the below script in the VBA editor.
Public Sub SaveAttachmentsToDisk(MItem As Outlook.MailItem)
Dim oAttachment As Outlook.Attachment
Dim sSaveFolder As String
sSaveFolder = "H:\temp\_nre_POs\"
For Each oAttachment In MItem.Attachments
oAttachment.SaveAsFile sSaveFolder & oAttachment.DisplayName
Set oAttachment = Nothing
Next
End Sub
I have also created the rule below to handle to subject line. The rule moving emails to the _Invoices folder has been in place and working fine for months, I just added the 'Run Script' option. I don't get any errors when running the rule on existing emails in the inbox, but I also don't have any attachments showing up in the destination folder. Ideally this should run in the background, but I'm open to a more manual process.
Pic of outlook rule
EDIT: I eventually got this to work using the script below. It may be a bit messy but it works.
Public Sub Application_Startup()
Dim MItem As MailItem
Dim oAttachment As Attachment
Dim sSaveFolder As String
Dim oDefInbox As Folder
Dim targetFolder As Folder
Dim myItems As Outlook.Items
Dim Item As Object
Set oDefInbox = Session.GetDefaultFolder(olFolderInbox)
Set targetFolder = Session.GetDefaultFolder(olFolderInbox).Parent.Folders("_Invoices")
sSaveFolder = "H:\temp\_nre_POs"
For Each MItem In targetFolder.Items
If MItem.UnRead = True Then
For Each oAttachment In MItem.Attachments
oAttachment.SaveAsFile sSaveFolder & oAttachment.DisplayName
Set oAttachment = Nothing
Next oAttachment
MItem.UnRead = False
End If
Next MItem
End Sub

Answer 1

You can use event Application_NewMail in ThisOutlookSession module, that "occurs when one or more new email messages are received in the Inbox":
Private Sub Application_NewMail()
Set myOlApp = GetObject(, "Outlook.Application")
Set myNamespace = myOlApp.GetNamespace("MAPI")
Set myFolder = myNamespace.GetDefaultFolder(olFolderInbox)
Set myItem = myFolder.Items(1)
SaveAttachmentsToDisk myItem
End Sub

Answer 2

In this situation rules are buggy. Remove the move from the rule. Put the move action in the code.
Option Explicit
Public Sub SaveAttachmentsToDisk(MItem As MailItem)
Dim oAttachment As Attachment
Dim sSaveFolder As String
Dim oDefInbox As folder
Dim targetFolder As folder
sSaveFolder = "H:\temp\_nre_POs\"
For Each oAttachment In MItem.Attachments
oAttachment.SaveAsFile sSaveFolder & oAttachment.DisplayName
Set oAttachment = Nothing
Next
Set oDefInbox = Session.GetDefaultFolder(olFolderInbox)
' where the Invoices folder is directly below the Inbox
Set targetFolder = oDefInbox.folders("Invoices")
' If Invoices is nested deeper - https://stackoverflow.com/a/48916736/1571407
' in https://stackoverflow.com/questions/8322432/using-visual-basic-to-access-subfolder-in-inbox
MItem.Move targetFolder
End Sub