Outlook - Download Email Attachment

Option Explicit
Sub downloadAttachment()

Dim olApp           As Object
Dim olNS            As Object
Dim olFolder        As Object
Dim olItems         As Object
Dim olItem          As Object
Dim olAtt           As Object
Dim sSaveToFolder   As String
Dim Ans             As Long


Dim olstore As Object
Dim oRoot As Outlook.folder

For Each olstore In Application.Session.Stores
If olstore.GetRootFolder = "XXX@XXXX.com" Then
 Set oRoot = olstore.GetRootFolder
End If
Next

sSaveToFolder = "C:\Users\XXXXXXXXX" 'change the destination folder accordingly

Set olApp = CreateObject("Outlook.Application")
Set olNS = olApp.GetNamespace("MAPI")


Set olFolder = oRoot.Folders("Inbox").Folders("Account").Folders("Invoice") 'change the source folder accordingly
Set olItems = olFolder.Items


For Each olItem In olItems

    If olItem.Attachments.Count > 0 Then
        For Each olAtt In olItem.Attachments
            If Right(olAtt.FileName, 4) = ".pdf" Then
                If Len(Dir(sSaveToFolder & olAtt.FileName)) = 0 Then
                    olAtt.SaveAsFile sSaveToFolder & olAtt.FileName
                    olItem.Save
                Else
                    Ans = MsgBox(olAtt.FileName & " already exists.  Overwrite file?", vbQuestion + vbYesNo)
                    If Ans = vbYes Then
                        olAtt.SaveAsFile sSaveToFolder & olAtt.FileName
                        olItem.Save
                    End If
                End If
            End If
        Next olAtt
    End If
Next olItem

Set olApp = Nothing
Set olNS = Nothing
Set olFolder = Nothing
Set olItems = Nothing
Set olItem = Nothing
Set olAtt = Nothing

End Sub