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

2022-09-22

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

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

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

ライブラリの参照設定

Microsoft Scripting Runtime を参照できるようにします。

ツール>参照設定 から、Microsoft Scripting Runtime にチェックを入れて OK を押してください。

実行

実行してみます。

先に Outlook の画面で添付ファイルを保存したいメールを選んでおきます。
(CTRL押しながらぽちぽちして、複数選択していきます。)
そして、タブメニューから 実行>マクロの実行 です。

現在のフォーカスがある位置によっては次のダイアログがでるので、 SaveAttachmentFiles を選んで実行をおします。

保存が完了すると、保存先のパスが表示されて完了です。

1つ1つのメールからファイルを順番にダウンロードするような修行からさよならしよう(。-`ω-)

技術Outlook

Posted by 86