The following will save the attachments from a selected message to C:\Reports\ (which must pre-exist) and delete the message. The additional functions are to ensure that existing files of the same name are not overwritten, but are appended with an incrementing number.

The If Not olAttach.Filename Like "image*.*" Then condition is intended to eliminate random graphics files that are not attachments, but are treated as such. If your wanted attachments have names beginning 'image' then omit that condition.

Option Explicit

Sub SaveAttachments()
Dim olItem As MailItem
Dim olAttach As Attachment
Dim strFname As String
Dim strExt As String

Const strSaveFldr As String = "C:\Reports\"        'Folder must exist!
    On Error GoTo CleanUp
    Set olItem = ActiveExplorer.Selection.Item(1)
    If olItem.Attachments.Count > 0 Then
        For Each olAttach In olItem.Attachments
            If Not olAttach.Filename Like "image*.*" Then
                strFname = olAttach.Filename
                strExt = Right(strFname, Len(strFname) - InStrRev(strFname, Chr(46)))
                strFname = FileNameUnique(strSaveFldr, strFname, strExt)
                olAttach.SaveAsFile strSaveFldr & strFname
            End If
        Next olAttach
    End If
    olItem.Delete 'Deletes the message
CleanUp:
    Set olAttach = Nothing
    Set olItem = Nothing
lbl_Exit:
    Exit Sub
End Sub

Private Function FileNameUnique(strPath As String, _
                               strFilename As String, _
                               strExtension As String) As String
Dim lngF As Long
Dim lngName As Long
    lngF = 1
    lngName = Len(strFilename) - (Len(strExtension) + 1)
    strFilename = Left(strFilename, lngName)
    Do While FileExists(strPath & strFilename & Chr(46) & strExtension) = True
        strFilename = Left(strFilename, lngName) & "(" & lngF & ")"
        lngF = lngF + 1
    Loop
    FileNameUnique = strFilename & Chr(46) & strExtension
lbl_Exit:
    Exit Function
End Function

Private Function FileExists(ByVal Filename As String) As Boolean
Dim nAttr As Long
    On Error GoTo NoFile
    nAttr = GetAttr(Filename)
    If (nAttr And vbDirectory) <> vbDirectory Then
        FileExists = True
    End If
NoFile:
    Exit Function
End Function