Saving attachments in multiple emails in outlook 365

I had to do this in a prior job, here is the code I used.

This code reads an incoming subfolder directly under the INBOX, strips out the attachments to the specified Excel folder and then moves the mail to a processed folder that is directly under the subfolder

Set up the parameters as named ranges. Look at the initialize variables section to get the names.

The only thing that should need explanation is KeepFiles. It defines what kind of files you want to download separated by columns. So *.xlsx,*.csv will download XLSX files and CVS files if any but not PDF, JPEG or other types of files.

Dim KeepFiles() As String               ' Type of files to keep
Dim kf As Long                          ' Pointer to file types to keep

Sub ProcessReport()
Dim olApp As Object                     ' Outlook Application
Dim olNS As Object                      ' Outlook Name Space
Dim FldrIn As Object                    ' Dock Schedule folder
Dim FldrOut As Object                   ' Dock Schedule processed folder
Dim olAtt As Object                     ' Outlook attachement
Dim k As Long                           ' Index to folder item
Dim FileName As String                  ' File names in folder

Dim MailBox As String                   ' Labor Analysis mailbox
Dim InFolder As String                  ' Dock Schedules folder in Outlook
Dim SubFolder As String                 ' Processed folder in Outlook
Dim ExcelFolder As String               ' Folder to which to download attachments
Dim KeepFileTypes                       ' File Types to keep

Const olMailItem As Long = 0

' Initalize variables
MailBox = Range("MailBox")
InFolder = Range("In_Folder")
SubFolder = Range("Sub_Folder")
ExcelFolder = Range("Excel_Folder")
KeepFileTypes = Range("Keep_File_Types")
KeepFiles = Split(KeepFileTypes, ",")


' Set up mailbox
Set olApp = CreateObject("Outlook.Application")
Set olNS = olApp.GetNamespace("MAPI")
Set FldrIn = olNS.Folders(MailBox).Folders("Inbox").Folders(InFolder)
DoEvents
Set FldrOut = olNS.Folders(MailBox).Folders("Inbox").Folders(InFolder).Folders(SubFolder)

Application.ScreenUpdating = False
Application.DisplayAlerts = False

' Go through mail items bottom to top
For k = FldrIn.Items.Count To 1 Step -1
    DoEvents
    Application.StatusBar = FldrIn.Items(k).Subject
    ' Get all attachments in the downloaded email
    For Each olAtt In FldrIn.Items(k).Attachments
        DoEvents
        ' Load them to the Excel Directory if they are "keepers"
        For kf = 0 To UBound(KeepFiles)
            If KeepFile(olAtt.FileName) = True Then
                olAtt.SaveAsFile ExcelFolder & "\" & olAtt.FileName
                DoEvents
                Exit For
            End If
        Next kf
    Next olAtt

    ' Move the message to the Processed folder and mark it as read
    FldrIn.Items(k).UnRead = False
    FldrIn.Items(k).Move FldrOut
    DoEvents
Next k

' Clean up Outlook
Set FldrIn = Nothing
Set olNS = Nothing
Set olApp = Nothing

Application.DisplayAlerts = True
Application.ScreenUpdating = True

Application.StatusBar = False

End Sub

Function KeepFile(AttachString As String) As Boolean
For kf = 0 To UBound(KeepFiles)
    If AttachString Like KeepFiles(kf) Then
        KeepFile = True
        Exit Function
    End If
Next kf
KeepFile = False
End Function