Auto saving Outlook attachments VBA - 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

Answer 1

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