【ExcelVBA】Outlookフォルダ内添付ファイル一括保存

'GetNamespaceメソッドでOutlookのNamespaceオブジェクト取得をする
Dim olns As Namespace
Set olns = GetNamespace("MAPI")

'MAPIFolderオブジェクトをセット
Dim olmf As MAPIFolder
Set olmf = olns.Application.ActiveExplorer.CurrentFolder

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 & "その他"

    Dim olns As Namespace
    Dim olmf As MAPIFolder
    Dim x As Long

    Set olns = GetNamespace("MAPI")
    Set olmf = olns.Application.ActiveExplorer.CurrentFolder

    For x = 1 To olmf.Items.Count
        '添付ファイルを保存する
        For Each attFile In olmf.Items(x).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

    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
    Set olns = Nothing
    Set olmf = Nothing
End Sub