Public Sub Extract_Outlook_Email_Attachments()
 Dim OutlookOpened As Boolean
 Dim outApp As Outlook.Application
 Dim outNs As Outlook.NameSpace
 Dim outFolder As Outlook.MAPIFolder
 Dim outAttachment As Outlook.attachment
 Dim outItem As Object
 Dim saveFolder As String
 saveFolder = "C:Usersborjax01Desktopaging reports"
 Dim outMailItem As Outlook.MailItem
 Dim inputDate As String, subjectFilter As String
 If Right(saveFolder, 1) <> "" Then saveFolder = saveFolder & "" & "Aging
 Report.out"

 inputDate = InputBox("Enter date to filter the email subject", "Extract
 Outlook email attachments")
 If inputDate = "" Then Exit Sub

 InputDateFilter = inputDate
 subjectFilter = ("VERIPRD : XXVER Veritiv Aging Report Main : PETROP01")


 OutlookOpened = False
 On Error Resume Next
 Set outApp = GetObject(, "Outlook.Application")
 If Err.Number <> 0 Then
     Set outApp = New Outlook.Application
     OutlookOpened = True
 End If
 On Error GoTo 0

 If outApp Is Nothing Then
     MsgBox "Cannot start Outlook.", vbExclamation
     Exit Sub
 End If

 Set outNs = outApp.GetNamespace("MAPI")
 Set outFolder = outNs.PickFolder


 If Not outFolder Is Nothing Then
    For Each outItem In outFolder.Items
        If outItem.Class = Outlook.OlObjectClass.olMail Then
            Set outMailItem = outItem
             If outMailItem.Subject = subjectFilter Then
                 Debug.Print outMailItem.Subject
                 For Each outAttachment In outMailItem.Attachments
                outAttachment.SaveAsFile saveFolder


              Set outAttachment = Nothing


                 Next
             End If
         End If
     Next
 End If

 If OutlookOpened Then outApp.Quit

 Set outApp = Nothing

End Sub