CODEWITHSUNDEEP
vbaoutlook
SQLSqirrel
SQLSqirrel

Reputation: 9

How to automatically save attachments from Outlook?

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

Upvotes: 0

Views: 7219

Answers (2)

niton
niton

Reputation: 9199

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

Upvotes: 0

Алексей Р
Алексей Р

Reputation: 7627

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

Upvotes: 0

Related Questions