表示中のフォルダーに含まれるアイテムの添付ファイルをすべて保存するマクロ

「受信したメールの添付ファイルを自動保存するマクロ」のコメントで、このマクロの処理を手動で実行したいというご要望をいただきました。

現在表示されているフォルダーに含まれるアイテムの添付ファイルをすべて保存するような処理は以下のようなマクロで実現できます。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub SaveAttachmentsInCurrentFolder()
    Dim objItem As Object ' MailItem
    For Each objItem In ActiveExplorer.CurrentFolder.items
        SaveAttachmentsInOneItem objItem
    Next
End Sub
'
Private Sub SaveAttachmentsInOneItem(objItem As Object)
    Const SAVE_PATH = "C:\attachments\"
    Dim objFSO As Object ' FileSystemObject
    Dim objAttach As Attachment
    Dim strFileName As String
    Dim c As Integer
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    '
    ' ここで条件指定
    ' If Not objItem.Subject Like "*Report*" Then Exit Sub
    '
    For Each objAttach In objItem.Attachments
        With objAttach
            strFileName = SAVE_PATH & objAttach.FileName
            c = 2
            While objFSO.FileExists(strFileName)
                strFileName = SAVE_PATH & Left(.FileName, InStrRev(.FileName, ".") - 1) _
                    & "-" & c & Mid(.FileName, InStrRev(.FileName, "."))
                c = c + 1
            Wend
            .SaveAsFile strFileName
        End With
    Next
    '
    Set objFSO = Nothing
End Sub


マクロの登録方法やメニューへの追加について

なお、このマクロの例ではフォルダーにあるすべてのメールの添付ファイルを保存しますが、特定の条件の場合だけ保存したということもあるでしょう。
その場合、「' ここで条件指定」のところに保存する条件を指定し、条件に合わない場合 Exit Sub で保存処理を行わずに終了するという記述を行います。
たとえば、「Report」という単語を件名に含むメールの添付ファイルだけを保存したいという場合は、以下のように記述します。

    If Not objMsg.Subject Like "*Report*" Then Exit Sub