Proszę spróbować tego:

Public Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String

 
    ' gdzie zapisujemy
    strFolderpath = "c:\ERAPORTY\"
    On Error Resume Next
 
 
    Set objOL = CreateObject("Outlook.Application")
    Set objSelection = objOL.ActiveExplorer.Selection
 
    ' dla wszystkich zaznaczonych maili
    For Each objMsg In objSelection
 
    Set objAttachments = objMsg.Attachments
    lngCount = objAttachments.Count
         
    ' moga nie miec załączników
    If lngCount > 0 Then
     
    ' od ostatniego załącznika do pierwszego
    For i = lngCount To 1 Step -1
     
    ' pobieramy nazwe pliku załącznika
    strFile = objAttachments.Item(i).FileName
     
        ' sprawdzamy czy to jest włąściwa nazwa
        If Left(strFile, 7) = "eraport" Then
    
        ' jezeli tak to zapisujemy
        strFile = strFolderpath & strFile
     
        objAttachments.Item(i).SaveAsFile strFile
    
        End If
    Next i
    End If
     
    Next
     
ExitSub:
 
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub