Save Attachments from Outlook based on Sender and Subject

[vzdog]

Hello everyone. I have a VBA script cobbled together that will successfully capture an email attachment from a specific sender with a specific subject. My problem is that it will only capture 1 instance.I would like to be able to add additional Senders and Subjects to capture - and be able to specifiy the path to save the attachment in to (likely a different drive and folder).I am not a VBA user at all, so I would appreciate any assistence offered.


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 = "Last, First") And _
(Msg.Subject = "My_Special_File") 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 = "I:\Test\Folder\"


' 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


ProgramExit:
Exit Sub

ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub