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

前回の記事で、Outlook内の選択しているメールから添付ファイルを取り出して保存する方法について紹介しました
でも、Outlookはあらかじめ「仕訳ルール」を設定しておき、特定の受信メールを自動的に指定フォルダに振り分ける機能があります。実際に私の職場でも「仕訳ルール」が設定されており、報告メールなどは自動振り分けされて指定フォルダ内に保存された状態になっています

この状態ならば、あらためてメールを選択する必要はないんですよね。フォルダを指定(選択)しておいて、その中のメールを一括処理できればもっと効率的ですよね(^^)

ということで、今回は前回記事の応用編です

ExcelVBAでOutlookで選択しているフォルダ内メールの添付ファイルを取り出す方法です

Outlookフォルダ内メールから添付ファイルを抜き出すには

はじめに

ExcelVBAでOutlookを扱えるようにするための「参照設定」などの事前準備は前回記事を見てください

今回使用するその他のオブジェクト

・Outlookのフォルダにアクセスするため必要なオブジェクトを追加でセットします

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

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

GetNamespaceメソッドでOutlookのNamespaceオブジェクトを取得します
Namespaceオブジェクトでデータフォルダーへアクセスし、GetNameSpace (“MAPI”)でフォルダ内のメールへのアクセスが可能となります
選択しているフォルダをMAPIFolderオブジェクトにセットして使用します

フォルダ内の全メールに添付されているファイルを一括保存

・Outlookの選択しているフォルダ内のすべてのメールから添付ファイルを一括保存します
 (事前にOutlookの対象メールフォルダを選択しておいてから実行します

選択フォルダ内のすべてのメールから添付ファイルを取り出すコード

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

コードの補足説明

今回のコードも前回記事のコード同様に、指定した保存先フォルダにサブフォルダ「Excel」と「その他」を作成して、ファイルの拡張子で保存先を振り分けるようにしています
不要な場合、または設定を変えたい(もっと細かく振り分ける)場合は該当部分のコードを直して使用してください(前回記事参照

まとめ

コードを実行してみた感想

メールを複数選択する手間が削減できて効率化がさらに進みました(^^♪

・雑多なメールの中から目的のメールを探して選択することも手間がかかります
「仕訳ルール」で添付ファイルがあるメールを指定フォルダに振り分ける
または、メールタイトルなどで振り分けておくなどしておけば効率的ですね

今後は

今回の記事はいかがだったでしょうか。お役に立てたなら幸いです

【今後の記事内容はどうしようかなぁ・・・】
・ExcelからOutlook 2016でメールを送信する方法
・データ表から同一種別データ毎に抽出して別ファイルに分割保存する方法
・高速化した「VlookUp関数」のVBAでの活用法を再検討してみたいと思います
・その他「小ネタ」などなど・・・・・
・次回はこれらのどれかについて記事にしていきたいと思います。ご期待ください(^^)/

サンプルファイルをダウンロードできます(下記リンク先へ)

記事で使用したサンプルファイルがダウンロードできるページを設置しています
こちら(このリンク先)からご利用ください