こんにちは、くのへ@MasazaneKunoheです。
前回に改良を加え、次の4点を改善しました～

Outlookでより便利なコードになった思いますので公開します。
(さらにメール中の埋め込み画像を添付資料として保存しないマクロはこちら。）

１）受信ボックスで選択しているメールを一発で保存（前回は「開いた」メールを一発保存）
２）名前入力をキャンセルしたらフォルダ作成や保存作業を行わない
３）デスクトップのアドレスは入力不要
４）コードの可読性UP

メール本体と添付資料を一発で保存

コードの機能はこんな感じです

① Outlookの受信ボックスでメールを選択している状態でこのマクロを動かすと、デスクトップにフォルダができてメール本体と添付資料が保存されます。

②デスクトップに作成されるフォルダ名は、ダイヤログボックスで入力するようにしています。名前を入力すると、今日の日付＋名前（入力値）のフォルダが生成されます。メールの受信日や送信日ではなく、実際にマクロを実行した日が書かれます

③メール本体の名前も②で入力した名前になります。

コード

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

Sub 受信BOXでメール保存()
  
'受信ボックスで選択している1番目のメールを抽出する
  
  Dim objSelect As Outlook.Selection
  Dim objItem As Object
  Set objSelect = Outlook.Application.ActiveExplorer.Selection
  Set objItem = objSelect.Item(1)
  
'デスクトップのアドレスを取得
  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.SaveAs strPath & strName & "¥" & strName & ".msg"

'objItemに入っている添付資料をフォルダに保存する
  Dim objAttachment As Object
  Dim strFile As String

  With objItem
    For Each objAttachment In .Attachments
        strFile = strPath & strName & "¥" & objAttachment
        objAttachment.SaveAsFile strFile
    Next objAttachment
  End With

'各オブジェクト達をNothingで消しておく
  Set objSelect = Nothing
  Set objItem = Nothing
  Set wsh = Nothing
  Set objFSO = Nothing
  Set objAttachment = Nothing

End Sub

動作の動画

謝辞

Notingの件を教えて頂いたTwitter友人のきょろさん、本当にありがとうございました。😆👍

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

感想等はツイッターにお願いします。こちら。
くのへスタジオはこちら。
Outlook-VBAコーナーはこちら。