こんにちは、くのへ@MasazaneKunoheです。

こんなリプを頂きました。

やだなにこれ超楽しそうｗ

ということで早速作ってみました。

複数選択したメールの添付資料をデスクトップに一発保存

早速つくりました＠2021/06/14
R1：同名ファイルがあった場合、2つ目以降には拡張子の前にカッコ付き通し番号を打つようにしました@2021/06/15
R2：コードの可読性を上げるため、ちょっとコードを見直しました@2021/06/22

↓コピペで動くと思います

Sub 受信BOXで複数メール添付ファイル保存()
  
'受信ボックスで選択しているメール（複数可）を抽出する
  Dim objItems As Object
  Set objItems = ActiveExplorer.Selection
    
'デスクトップのアドレスを取得
  Dim wsh As Object
  Dim strPath As String
  
  Set wsh = CreateObject("WScript.Shell")
  strPath = wsh.SpecialFolders(4) & "\"
    
'フォルダ名をダイヤログボックスで取得
  Dim strName As String
  strName = InputBox("フォルダ名を記載ください", "フォルダ作成", "フォルダ名")
  If StrPtr(strName) = 0 Then Exit Sub  'キャンセル時にマクロ終了
  strName = Left(Date, 4) & Mid(Date, 6, 2) & Mid(Date, 9, 2) & "_" & strName

'フォルダを作る
  Dim objFSO As Object
  Set objFSO = CreateObject("Scripting.FileSystemObject")
  objFSO.CreateFolder strPath & strName

'objItemに入っている添付資料をフォルダに保存する
  Dim objAttachment As Object
  Dim strFile As String
  Const PR_ATTACH_CONTENT_ID As String = "http://schemas.microsoft.com/mapi/proptag/0x3712001F"

'objItemsコレクションの中身を一つずつ格納する変数objItemを設定
  Dim objItem As Object
  
  Dim i As Integer
  Dim strCheckFileName As String
  
  For Each objItem In objItems
  
    With objItem
      For Each objAttachment In .Attachments
        If objAttachment.Type <> 6 And _
        (objAttachment.PropertyAccessor.GetProperty(PR_ATTACH_CONTENT_ID) = "" Or _
        Right(objAttachment.PropertyAccessor.GetProperty(PR_ATTACH_CONTENT_ID), 11) = "outlook.com") Then
               
            '同名ファイルがあれば、拡張子の手前に通し番号を記載
            strFile = strPath & strName & "\" & objAttachment
            strCheckFileName = strFile
            i = 1
            
            Do While Dir(strCheckFileName) <> ""
              strCheckFileName = Replace(strFile, Mid(strFile, InStrRev(strFile, ".")), "") & "(" & i & ")" & Mid(strFile, InStrRev(strFile, "."))
              i = i + 1
            Loop
            
            '添付ファイルを保存
            objAttachment.SaveAsFile strCheckFileName
        
        End If
      Next objAttachment
    End With
    
  Next objItem
  
  '各オブジェクト達をNothingで消しておく
  Set objItems = Nothing
  Set objItem = Nothing
  Set wsh = Nothing
  Set objFSO = Nothing
  Set objAttachment = Nothing

End Sub

解説

このコードはこんなことをやっています

①受信ボックスで選択しているメール（複数可）を抽出する
②デスクトップのアドレスを取得
③フォルダ名をダイヤログボックスで取得
④フォルダを作る
⑤objItemに入っている添付資料をフォルダに保存する
⑥各オブジェクト達をNothingで消しておく

コードにメモっている通りです。

①受信ボックスで選択しているメール（複数可）を抽出する

まず、このコードでOutlookウィンドウで選択しているメールを「objItems」に設定しています。
「Outlookのアクティブなウィンドウの選択中のアイテム」を示すコードは「ActiveExplorer.Selection」です。

  Dim objItems As Object
  Set objItems = ActiveExplorer.Selection

②デスクトップのアドレスを取得

デスクトップのアドレスをVBAで指定するのは、地味に難しい技の一つです。
デスクトップのアドレスは、↓こんな感じになっています。
　C:\Users\user\Desktop
そう、「ユーザー名」がアドレスに間に入っちゃうんです。そのため汎用性のあるコードを書こうとすると地味に難しいです。

どんなPCでもデスクトップを指定したい！！という時に使うのが「WSH」の「SpecialFolders(4)」です。
WSH？　Special、、、ふぁっ？　と思った方もおられるかと思います。これを知っていたら私の中では中級VBAerです。
難しい話は抜きにして、↓このようにコーディングすましょう。すると、strPathにデスクトップ（最後に「¥」マーク付き）アドレスが代入されます。

  Dim wsh As Object
  Dim strPath As String
  
  Set wsh = CreateObject("WScript.Shell")
  strPath = wsh.SpecialFolders(4) & "\"

SpecialFolders(X)のXに、次の「文字列」もしくは「値」を入力すると、各種フォルダアドレスが手に入ります。
以下に抜粋を載せますが、この記事の最後の「資料」コーナーに置いておきます。

③フォルダ名をダイヤログボックスで取得

コードの↓この部分でダイヤログボックスを使ってフォルダ名を記入させて取得しています。

  Dim strName As String
  strName = InputBox("フォルダ名を記載ください", "フォルダ作成", "フォルダ名")
  If StrPtr(strName) = 0 Then Exit Sub  'キャンセル時にマクロ終了
  strName = Left(Date, 4) & Mid(Date, 6, 2) & Mid(Date, 9, 2) & "_" & strName

この、「InputBox」メソッドがミソです。

strName = InputBox(“A”, “B”, “C”)と書くとこんなウィンドウが出てきます。

そう。こうなってます。
　A：説明文
　B：ウィンドウの名前
　C：記入してもらう部分のデフォルト値
そして、「C」と書かれている入力欄を書き換えて「OK」を押すと、strNameに入力した文字列が代入される、という仕組みです。

あとは、Date関数を使えば「2021/06/22」という数字が返ってくるので、Left関数やMid関数で「20210622」という年月日データをつくり、アンダーバーを使って、「20210622_フォルダ名」というフォルダ名データを作っています。

なお、キャンセルボタンやウィンドウの×ボタンが押された場合、strNameは””（空）が代入され、プログラムはそのまま処理を続けようとします。
「キャンセルされた」・「×ボタンを押された」・「記入欄に何も記載されなかった」場合には、このコードを止めるようにします。
それには、 「If StrPtr(strName) = 0 Then Exit Sub 」を使います。

StrPtrは変数の中のデータのメモリアドレスを調べる関数であり、対象のデータが””（空）の場合、0となるという関数です。これを利用して、strNameにデータが入っていなければ（すなわちキャンセル等をされたならば）プログラム処理をExit Subで停止させるようにしています。
なお、StrPtr関数はInputboxとセットで使われる以外はあまりお目にかかりません。

④フォルダを作る

フォルダを作るために、いわゆる「FSO（File System Object）」を使っています。
このコードの部分です。

  Dim objFSO As Object
  Set objFSO = CreateObject("Scripting.FileSystemObject")
  objFSO.CreateFolder strPath & strName

上2行でobjFSOを準備しています。
そして、objFSOの準備が出来れば、objFSOオブジェクトを上位とした「CreateFolderメソッド」が使えるようになります。

このメソッドは読んで字のごとく、フォルダを作る命令文です。書式は以下の通り。

objFSO.CreateFolder フォルダ名までのフルパス

これでフォルダを作れます。
strPathにデスクトップのアドレス（最後に¥マーク付き）が入っていて、strNameにInputBoxで入力して貰ったフォルダ名が入っているので、この組み合わせでデスクトップにフォルダを作っています。

⑤objItemに入っている添付資料をフォルダに保存する

ここが一見複雑で難しい。

  For Each objItem In objItems
  
    With objItem
      For Each objAttachment In .Attachments
        If objAttachment.Type <> 6 And _
        (objAttachment.PropertyAccessor.GetProperty(PR_ATTACH_CONTENT_ID) = "" Or _
        Right(objAttachment.PropertyAccessor.GetProperty(PR_ATTACH_CONTENT_ID), 11) = "outlook.com") Then
               
            '同名ファイルがあれば、拡張子の手前に通し番号を記載
            strFile = strPath & strName & "\" & objAttachment
            strCheckFileName = strFile
            i = 1
            
            Do While Dir(strCheckFileName) <> ""
              strCheckFileName = Replace(strFile, Mid(strFile, InStrRev(strFile, ".")), "") & "(" & i & ")" & Mid(strFile, InStrRev(strFile, "."))
              i = i + 1
            Loop
            
            '添付ファイルを保存
            objAttachment.SaveAsFile strCheckFileName
        
        End If
      Next objAttachment
    End With
    
  Next objItem

ね。難しいよね。

これをポイントにフォーカスすると、こうなってます。

  For Each objItem In objItems
    With objItem
      For Each objAttachment In .Attachments
        （If文）
　　　　　（Do文）
            objAttachment.SaveAsFile strCheckFileName        
      Next objAttachment
    End With
  Next objItem

ただの2重繰り返し構文で、添付ファイル（objAttachment）をSaveAs（保存）してるだけなのね。

そして、外側のFor Each文は、選択中のすべてのメールを1つずつのメールに分けて、繰り返すコードで、
内側のFor Each文は、1つのメールの複数の添付資料を1つずつの添付資料に分けて繰り返すコード、になってます。

If文では、メールの「埋め込み画像」は対象外にするコードを仕込んでいます。詳しい別記事で（こちら）。

Do文では、Dir関数を使って同じファイル名があるかどうか判別し、同名ファイルがあれば「i」を増やして、通し番号を作っています。

⑥各オブジェクト達をNothingで消しておく

最後にオブジェクトの中身をNothingで削除して、思わぬ動作を防止しています。
これも呪文みたいなもんだね～。SetしたオブジェクトはNothingしておくと思わぬバグを防げます。

ではまた別の記事で～
🦅バサバサ～

くのへスタジオはこちら。
Outlook-VBAコーナーはこちら。

資料

WSHのSpecialFolder(X)の「X」に以下「文字列」もしくは「値」を入力すると、各種フォルダのアドレスが返ります。