CODEWITHSUNDEEP
vbaoutlook
Kyle Murray
Kyle Murray

Reputation: 25

Auto saving Outlook attachments VBA

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

Upvotes: 1

Views: 169

Answers (1)

Ryan Wildry
Ryan Wildry

Reputation: 5677

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

Upvotes: 1

Related Questions