Auto saving Outlook attachments VBA

Question

I've been playing around with the below code in an attempt to save files which we receive daily in Outlook. The code seems to run fine, however, when I go to check the destination folder there are no attachments saved.

How can I modify the code to save the attachments to the specified folder?

 Private WithEvents Items As Outlook.Items

    Private Sub Application_Startup()
        Dim olApp As Outlook.Application
        Dim objNS As Outlook.NameSpace
        Set olApp = Outlook.Application
        Set objNS = olApp.GetNamespace("MAPI")
        Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
    End Sub

    Private Sub Items_ItemAdd(ByVal item As Object)

    On Error GoTo ErrorHandler

        'Only act if it's a MailItem
        Dim Msg As Outlook.MailItem
        If TypeName(item) = "MailItem" Then
            Set Msg = item

        'Change variables to match need. Comment or delete any part unnecessary.
            If (Msg.SenderName = "made-up-email@some_domain.com") And _
            (Msg.Subject = "Test") And _
            (Msg.Attachments.Count >= 1) Then

        'Set folder to save in.
        Dim olDestFldr As Outlook.MAPIFolder
        Dim myAttachments As Outlook.Attachments
        Dim Att As String

        'location to save in.  Can be root drive or mapped network drive.
        Const attPath As String = "T:\London File3 Group\Client Reporting\Test"


        ' save attachment
           Set myAttachments = item.Attachments
        Att = myAttachments.item(1).DisplayName
        myAttachments.item(1).SaveAsFile attPath & Att

        ' mark as read
          Msg.UnRead = False
          End If
          End If
          End Sub

attPath & Att should be attPath & "\" & Att If you comment out your error handling the problem should be clearer — Tim Williams
I followed these instructions but the files are still not saving! What am I missing? There's no error as the code runs without any errors flagged without error handling. — Kyle Murray
Have you placed breakpoints and tried to debug your code to see which parts are actually executing? — Tim Williams
No - I will try and do this now. I'm just confused that if there is no error then this implies the code has run fine? — Kyle Murray
"Run without errors" and "run as expected" aren't always the same thing ;-) — Tim Williams

Ryan Wildry Ryan Wildry · Accepted Answer · 2019-01-03T18:08:41

This code should work, something you may not have done is added this to the ThisOutlookSession object. Don't add to a standard module.

Private WithEvents InboxItems As Outlook.Items
Const attPath As String = "T:\London File3 Group\Client Reporting\Test\"

Private Sub Application_Startup()
    Dim outlookApp As Outlook.Application: Set outlookApp = Outlook.Application
    Dim objectNS As Outlook.NameSpace: Set objectNS = outlookApp.GetNamespace("MAPI")
    Set InboxItems = objectNS.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub InboxItems_ItemAdd(ByVal Item As Object)
    Dim Msg             As Outlook.MailItem: Set Msg = Item
    Dim olDestFldr      As Outlook.MAPIFolder
    Dim myAttachments   As Outlook.Attachments
    Dim Filename        As String

    If Not TypeName(Msg) = "MailItem" Then Exit Sub
    If (Msg.SenderName = "made-up-email@some_domain.com") And (Msg.Subject = "Test") And (Msg.Attachments.Count >= 1) Then
        Set myAttachments = Item.Attachments
        Filename = myAttachments.Item(1).DisplayName
        myAttachments.Item(1).SaveAsFile attPath & Filename
        Msg.UnRead = False
    End If
End Sub

Auto saving Outlook attachments VBA

1 Answers