◆Outlook VBA（複数メールの添付ファイルを一括保存）

今回はOutlookメールの添付ファイルを保存する機能について書いてみたいともいます。前回のカスタマイズ記事でカスタムメニューの画像を出していたのでネタばれだったかもしれませんね。

１つのメールに添付されているファイルを保存する機能は標準でありますね。メニュー「ファイル」→「添付ファイルの保存」→「すべての添付ファイル」です。でも複数メールの添付ファイルを一括保存する場合、あれっできない？Microsoftさん！？。。。

2010.9.10加筆
保存先に同じファイル名が存在したら重複しないように枝番を付加するように改良したヴァージョンはこちら

ということで作成したのが以下の処理です。

Sub 選択メールの添付ファイルを指定フォルダに一括保存()
    Dim cDir As String, oSel As Object, oF As Object
    Dim myOlApp As New Outlook.Application
    Dim myOlExp As Outlook.Explorer
    Dim myOlSel As Outlook.Selection
    Dim myNameSpace As Outlook.NameSpace
    Dim myFolder As Outlook.MAPIFolder
    Dim mySendFolder As Outlook.MailItem
    Dim myCopiedItem As Outlook.Items
    Dim lMax As Integer, i As Integer
    Dim MyTitle As String
    Dim Leng As Long, hWnd As Long, ret As Long
   
    Dim myAttachments As Outlook.Attachment
    Dim MsgTxt As String, a As String
    Dim myExlApp As Object, Files As Object
    Dim lSubject As String
   
    On Error Resume Next
    Set myOlApp = CreateObject("Outlook.Application")
    Set myOlExp = myOlApp.ActiveExplorer
    Set myOlSel = myOlExp.Selection
   
    Set myExlApp = CreateObject("excel.Application")
    cDir = myExlApp.GetSaveAsFilename("DUMMY", "全ﾌｧｲﾙ(*.*),*.*", , "保存先フォルダ指定")
    If cDir = "False" Or cDir = "FALSE" Then GoTo p_exit
   
    cDir = Mid(cDir, 1, InStrRev(cDir, "\") - 1)
   
    '現在のｳｨﾝﾄﾞｳﾀｲﾄﾙ取得
    hWnd = GetActiveWindow()
    MyTitle = String(250, Chr(10))
    Leng = Len(MyTitle)
    ret = GetWindowText(hWnd, MyTitle, Leng)

    '選択されたﾒｰﾙの添付ﾌｧｲﾙを保存
    For Each oSel In myOlSel
        i = i + 1
        ret = SetWindowText(hWnd, oSel & "(" & i & "/" & myOlSel.Count & ")" & "を処理中...")
        For Each oF In oSel.Attachments
            oF.SaveAsFile cDir & "\" & oF.DisplayName
        Next
       
    Next
   
    ret = SetWindowText(hWnd, MyTitle)
    MsgBox "終了しました。総数：" & i
    ret = Shell("c:\windows\explorer.exe " & cDir, vbNormalFocus)

p_exit:
    Set myExlApp = Nothing
    Set oSel = Nothing
    Set oF = Nothing
    Set myOlApp = Nothing
    Set myOlExp = Nothing
    Set myOlSel = Nothing
   
End Sub

解説すると、例のごとくSet myOlApp = CreateObject("Outlook.Application")でOutlookオブジェクトを作成し、Set myOlSel = myOlExp.Selectionで選択されているメールを取得します。Set myExlApp = CreateObject("excel.Application")でExcelのオブジェクトを生成し、ExcelのGetSaveAsFilename関数をフォルダ指定に流用しています。ここは"shell.application"のbrowseforfolderでも良いし他にもあるかもしれません。ちなみに、予めChDirをしたかったのですが、Outlookは有効にならないようです。For Each oSel In myOlSelで選択したメール分処理を繰り返します。さらに、For Each oF In oSel.Attachmentsでメールに添付された複数ファイル分処理を繰り返します。あとは、前回説明したタイトルバーの変更処理が含まれていますが割愛します。

以上が添付ファイルの一括保存についての説明でした。OutlookＶＢＡについては今回で終了とします。また、ネタが見つかったら書いてみたいと思います。

※私が作成したVBAツールです。よかったら使ってみてください。