Outlook macro for batch download of email attachments

batch-attachment-download.vb

Option Explicit
Sub SaveAttachments()
    Dim strPath As String
    Dim SH As Shell32.Shell
    Dim Fldr As Shell32.Folder
    Dim olFolder As Folder
    Dim olItem As MailItem
    Dim olAttach As Attachment
    
    Const strSubject As String = "VA SSIM" 'text to look for in the subject line
    Const strFileType As String = "zip" 'last three characters of filename extension
    
    
    Set SH = New Shell32.Shell
    Set Fldr = SH.BrowseForFolder(0, "Select the folder to store the attachments", &H400)
    On Error GoTo Err_Handler
    If Not Fldr Is Nothing Then
        If Right$(Fldr.Items.Item.Path, 1) <> "\" Then
            strPath = Fldr.Items.Item.Path & "\"
        End If
Err_ReEntry:
        Set olFolder = Application.Session.PickFolder
        For Each olItem In olFolder.Items
            If InStr(1, LCase(olItem.Subject), LCase(strSubject)) And _
               olItem.Attachments.Count > 0 Then
                For Each olAttach In olItem.Attachments
                    If Right(LCase(olAttach.FileName), 3) = strFileType Then
                        olAttach.SaveAsFile _
                                strPath & Format(olItem.ReceivedTime, "yyyymmdd-HHMM") & _
                                        Chr(32) & olAttach.FileName
                    End If
                Next olAttach
            End If
        Next olItem
    End If
    Set Fldr = Nothing
    Set SH = Nothing
    Set olFolder = Nothing
    Set olAttach = Nothing
    Set olItem = Nothing
    Exit Sub
Err_Handler:
    If Err.Number = 91 Then
        If Fldr.Title = "Desktop" Then
            strPath = Fldr.Items.Item(1).Path & "\Desktop\"
            Resume Err_ReEntry
        End If
    End If
End Sub