Private Sub SaveAttachments_Selection()
Dim item As Object
Dim ItemAttachment As Object
Dim StrFolderPath As String
Dim strFileName As String
Dim ItemsCount As Long
Dim ItemsAttachmentsCount As Long
Dim iSave As Long
Dim msg As String
StrFolderPath = "H:\test"
If (Dir$(StrFolderPath, vbDirectory) = "") Then
    Debug.Print "'" & StrFolderPath & "' not exist"
    MkDir StrFolderPath
    Debug.Print "'" & StrFolderPath & "' we create it"
Else
    Debug.Print "'" & StrFolderPath & "' exist"
End If
If Right(StrFolderPath, 1) <> "\" Then
   StrFolderPath = StrFolderPath & "\"
End If
ItemsCount = 0
ItemsAttachmentsCount = 0
 
For iSave = 1 To ActiveExplorer.Selection.Count
 
    Set item = ActiveExplorer.Selection(iSave)
 
    If TypeOf item Is mailItem Or TypeOf item Is PostItem Then
        ItemsCount = ItemsCount + 1
        For Each ItemAttachment In item.Attachments
            ItemsAttachmentsCount = ItemsAttachmentsCount + 1
            ' Get the file name.
            strFileName = ItemAttachment.FileName
            ' Combine with the path to the Attachments folder.
            strFileName = StrFolderPath & ItemsAttachmentsCount & "_" & strFileName
            ' Save the attachment as a file.
            ItemAttachment.SaveAsFile strFileName
        Next ItemAttachment
 
    End If
 
Next
ExitSub:
Set item = Nothing
msg = "Attachments Have Been saved to " & StrFolderPath & vbCr & vbCr
msg = msg & "ItemsCount : " & ItemsCount & vbCr & vbCr
msg = msg & "ItemsAttachmentsCount : " & ItemsAttachmentsCount
MsgBox msg
End Sub