【ExcelVBA】Outlook受信メールの添付ファイルを保存

'Outlookアプリケーションのインスタンスを作成（起動）
Dim app As New Outlook.Application
Set app = CreateObject("Outlook.Application")

'Explorerオブジェクト(Outlook)フォルダーの内容が表示されるウィンドウ
Dim exp As Outlook.Explorer
Set exp = app.ActiveExplorer
'Selectionオブジェクト(Outlook)Explorerで現在選択されているOutlookアイテム
Dim sel As Outlook.Selection
Set sel = exp.Selection

Sub 選択メールの添付ファイル一括保存()
    Dim olapp As Outlook.Application  'New Outlook.Application
    Dim olexp As Outlook.Explorer
    Dim olsel As Outlook.Selection
    Dim sel As Object, attFile As Object
    Dim fpath As String
    Dim pos As Long

    On Error GoTo ErrHandler
    Set olapp = CreateObject("Outlook.Application")
    Set olexp = olapp.ActiveExplorer

    '対象のメールが選択されているか確認メッセージを出す
    MsgBox "事前に対象のメールを選択しておいてくださいね！"
    
    Set olsel = olexp.Selection
    
    '添付ファイルの保存先フォルダを指定する
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then
            fpath = .SelectedItems(1)
        End If
    End With
　　'選択されていなかったら（キャンセル）終了する
    If fpath = "" Then GoTo ExitP
    fpath = fpath & "\"
    
    'サブフォルダ「Excel」と「その他」を作成
    If Dir(fpath & "Excel", vbDirectory) = "" Then MkDir fpath & "Excel"
    If Dir(fpath & "その他", vbDirectory) = "" Then MkDir fpath & "その他"

    '添付ファイルを保存する
    For Each sel In olsel
        For Each attFile In sel.Attachments 'Attachmentsコレクション
            pos = InStrRev(attFile.DisplayName, ".")
            If pos > 0 Then
                '拡張子の3文字でExcelファイルかどうか判定
                If LCase(Mid(attFile.DisplayName, pos + 1, 3)) <> "xls" Then
                    attFile.SaveAsFile fpath & "その他\" & attFile.DisplayName
                Else
                    attFile.SaveAsFile fpath & "Excel\" & attFile.DisplayName
                End If
            End If
        Next attFile
    Next sel

    MsgBox "終了しました。", vbOKOnly + vbInformation, "添付ファイル一括保存"
    GoTo ExitP

ErrHandler:
    MsgBox "エラーが発生しました！" & vbCrLf & Err.Description, _
                                    vbExclamation, "添付ファイル一括保存"

'終了処理
ExitP:
    Set sel = Nothing
    Set attFile = Nothing
    Set olsel = Nothing
    Set olexp = Nothing
    Set olapp = Nothing
End Sub

    'サブフォルダ「Excel」と「その他」を作成
    If Dir(fpath & "Excel", vbDirectory) = "" Then MkDir fpath & "Excel"
    If Dir(fpath & "その他", vbDirectory) = "" Then MkDir fpath & "その他"

    '添付ファイルを保存する
    For Each sel In olsel
        For Each attFile In sel.Attachments 'Attachmentsコレクション
            attFile.SaveAsFile fpath & attFile.DisplayName
        Next attFile
    Next sel