[Outlook] 複数のメールから添付ファイルを一括で取得する方法

2022-03-222022-09-22

最近、働き方改革やDXで紙での連絡が減った分、メールの添付ファイルで通知されることが増えました。
通知がメール１つなら簡単なのですが、たくさんのメールで通知されることも少なくありません。
（集約するの大変！添付ファイル１つずつ保存していくの大変！）

そこで、今回は Outlook で受信した複数のメールから、まとめて添付ファイルを保存する方法を紹介します。

Contents

1. Outlookを起動する
2. VBA のウィンドウを開く
3. 標準モジュールを挿入
4. プログラムを貼り付け
5. ライブラリの参照設定
6. 実行

Outlookを起動する

起動してください(/・ω・)/

VBA のウィンドウを開く

Alt + F11 を押します。

標準モジュールを挿入

Project1 にフォーカスを合わせて、挿入＞標準モジュールを選びます。

プログラムを貼り付け

挿入した標準モジュールを選択して、プログラムを貼り付けます。

貼り付けるプログラムはこちらです。

Public Sub SaveAttachmentFiles()
   On Error Resume Next

   Dim saveDir As String
   saveDir = CreateObject("WScript.Shell").SpecialFolders(16) & "\Attachment Files\"
   If VBA.Dir(saveDir, vbDirectory) = vbNullString Then
     VBA.MkDir saveDir
   End If

   Dim mailItem As Outlook.mailItem
   Dim attachments As Outlook.attachments
   Dim selection As Outlook.selection
   Dim i As Long
   Set selection = Outlook.Application.ActiveExplorer.selection
   For Each mailItem In selection
     Set attachments = mailItem.attachments
     If attachments.Count > 0 Then
       For i = attachments.Count To 1 Step -1
         If IsEmbedded(attachments.Item(i)) = False Then
           attachments.Item(i).SaveAsFile FileRename(saveDir & attachments.Item(i).FileName)
         End If
       Next i
     End If
   Next
   Set selection = Nothing
   Set attachments = Nothing
   Set mailItem = Nothing

   MsgBox saveDir & "に保存しました！"
End Sub

Function FileRename(FilePath As String) As String
   On Error Resume Next

   FileRename = FileRenameRecursive(FilePath, FilePath)
End Function

Function FileRenameRecursive(FilePath As String, BasePath As String, Optional Count As Long = 1) As String
   On Error Resume Next

   Dim path As String
   path = FilePath

   FileRenameRecursive = path

   Dim fileSystemObject As fileSystemObject
   Set fileSystemObject = CreateObject("Scripting.FileSystemObject")
   If fileSystemObject.FileExists(path) Then
     path = fileSystemObject.GetParentFolderName(BasePath) & "\" & fileSystemObject.GetBaseName(BasePath) & " (" & Count & ")." + fileSystemObject.GetExtensionName(BasePath)
     FileRenameRecursive = FileRenameRecursive(path, BasePath, Count + 1)
   End If
   fileSystemObject = Nothing
End Function

Function IsEmbedded(Attach As Attachment)
   On Error Resume Next

   IsEmbeddedAttachment = False

   Dim mailItem As mailItem
   Set mailItem = Attach.Parent
   If mailItem.BodyFormat <> olFormatHTML Then Exit Function

   Dim cid As String
   cid = ""
   cid = Attach.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x3712001F")
   If cid <> "" Then
     If InStr(mailItem.HTMLBody, "cid:" & cid) > 0 Then
       IsEmbeddedAttachment = True
     End If
   End If
End Function