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

前回のOutlook-VBAマクロを改造し、保存フォルダを選択式にしました。

Outlook-VBAからは直接ファイル選択ダイアログを出せない仕様になっているため、wordもしくはexcelの機能を拝借してファイル選択ダイヤログを出す必要があります。（今回はwordの機能を拝借）

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

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

① 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 strPath As String
  Dim appWord As Object 'Word.Applicationを呼び出すインスタンス
  Dim dig As FileDialog 'フォルダ選択ダイヤログを示すオブジェクト
  Set appWord = CreateObject("Word.Application")
  Set dig = appWord.FileDialog(Office.msoFileDialogFolderPicker)
  dig.Show
  If dig.SelectedItems.Count = 0 Then GoTo OUT1 'キャンセル時に閉じる
  strPath = dig.SelectedItems(1) & "\\"

'フォルダ名＆メール名をダイヤログボックスで取得
  Dim strName As String
  strName = InputBox("保存名を記載ください", "フォルダ作成", "保存名")
  If StrPtr(strName) = 0 Then GoTo OUT1  'キャンセル時にマクロ終了
  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 objAttachment = Nothing
  Set objFSO = Nothing
  Set dig = Nothing

OUT1: 'ダイアログでキャンセルしたらここに飛んでマクロ終了
  appWord.Quit  'wordをquitしておく。そうしないと再起動した時にwordが立ち上がる
  Set appWord = Nothing
  Set objItem = Nothing
  Set objSelect = Nothing

End Sub

動作の動画

少し解説

Outlook-VBAからは直接↓このコードでファイル選択ダイアログを出せない仕様になっています。
そこで、wordもしくはexcelの機能を拝借してファイル選択ダイヤログを出すようにしました。

'このコードはOutlookでは動かない
Dim strPath As String
Dim dig As FileDialog 'フォルダ選択ダイヤログを示すオブジェクト
Set dig = Application.FileDialog(msoFileDialogFolderPicker)
dig.Show
strPath = dig.SelectedItems(1) & "\\"

'このコードにすればOutlookで動く
Dim strPath As String
Dim appWord As Object 'Word.Applicationを呼び出すインスタンス
Dim dig As FileDialog 'フォルダ選択ダイヤログを示すオブジェクト
Set appWord = CreateObject("Word.Application")
Set dig = appWord.FileDialog(Office.msoFileDialogFolderPicker)
dig.Show
strPath = dig.SelectedItems(1) & "\\"
'・・・
'（中略）ここにコード本体
'・・・
appWord.Quit 'WordをQuitしておく。そうしないとPC再起動時にWordが立ち上がる

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

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