【OutlookVBA】メールの「名前を付けて保存」の効率化パターン②

【想定する実務】
①受信したメールを「名前を付けて保存」している
②メールの保存場所は毎回同じ（変えるにしても年1回）である（共通フォルダ等）
③メールの管理表をExcelで作っている

【処理の流れ】
①メール管理表（Excel）を開く
②Outlookからマクロを実行する。
③Excelシートから保存先のパスを取得し、保存する。

cha-hanman.hatenablog.com
上記の記事で、「名前を付けて保存」について書きました。
メールの保存場所が毎回違う想定でしたが、今度はメールの保存場所が毎回同じという想定のマクロです。
実務的にはこちらの方が多いでしょうか。
（メールというもの自体が古臭いという意見は聞こえないふりをします）

今回のマクロでは、OutlookからExcelをいじるので、VBEの「ツール」→「参照設定」から「Microsoft Excel 〇〇.〇　 Object Libraly」の追加が必要です。

また、Excel管理表の中にメール保存先のパスを記載する想定ですが、こちらのメンテナンスを容易にするために、以下の記事に記載のマクロを使ってもいいと思います。
（知識のある人が一人で使う分にはメンテナンスへの気遣いは不要だと思いますが）
cha-hanman.hatenablog.com

先に、処理の流れを画像で説明します。
①メール管理表を開きます。

エクセルの中身はこんな感じの想定です。

②Outlookを開いてメールを選択し、マクロを実行します。

③メールが指定した保存先に保存され、Excel管理表に受信日・件名が書き込まれます。

※添付ファイルがある場合には添付ファイルも保存されます。

以下、コードです。

Sub MailSave()

Dim objExcel As Object
Set objExcel = GetObject(, "Excel.Application")

'メールを開いていれば開いているメールをオブジェクトとして扱い、
'開いていなけば、エクスプローラー上で選択しているメールを
'オブジェクトとして扱う。
Dim objItem As Object
If TypeName(Application.ActiveWindow) = "Inspector" Then
Set objItem = Application.ActiveInspector.CurrentItem
Else
Set objItem = ActiveExplorer.Selection(1)
End If
 

'StrSubjectにメールの件名をセットし、
'不正なファイル名の原因となる文字をReplace
'（あとでStrSubjectを利用してフォルダを作るため）
Dim StrSubject As String
StrSubject = objItem.Subject
StrSubject = Replace(StrSubject, " ", "")
StrSubject = Replace(StrSubject, ":", "：")
StrSubject = Replace(StrSubject, "\", "￥")
StrSubject = Replace(StrSubject, "/", "／")
StrSubject = Replace(StrSubject, "|", "｜")
StrSubject = Replace(StrSubject, "<", "＜")
StrSubject = Replace(StrSubject, ">", "＞")
StrSubject = Replace(StrSubject, "?", "？")
StrSubject = Replace(StrSubject, "*", "＊")

Dim WSkanri As Worksheet
Set WSkanri = objExcel.Workbooks("メール管理表.xlsm").ActiveSheet

'管理表の空白行を探す｡
i = 4
Do While WSkanri.Cells(i, "B") <> ""
i = i + 1
Loop

'メール保存先に関する変数作成
'エクセルに設定してある保存先と件名をくっつけて
'メールの保存先パスを作成。
StrMailSaveFolder = WSkanri.Range("C2") 'エクセルシートから取得
StrMailSavePath = "" & StrMailSaveFolder & "\" & StrSubject & "\"
'フォルダ作成
If Dir(StrMailSavePath, vbDirectory) = "" Then
MkDir StrMailSavePath
Else
MsgBox ("同じタイトルのメールが既に保存されています。" _
& vbCrLf & "確認してください。")
Exit Sub
End If


'本文をtxtとして保存。
objItem.SaveAs StrMailSavePath & "\" & StrSubject & ".txt", olTXT

'添付ファイルの保存。
With objItem
For Each objAttachment In .Attachments
StrAttachSavePath = StrMailSavePath & "\" & objAttachment
objAttachment.SaveAsFile StrAttachSavePath
Next objAttachment
End With

   
'管理表への入力。
StrRecievedDate = Format(objItem.ReceivedTime, "yyyy/mm/dd")
'メールの受信日
With WSkanri
             .Cells(i, "B").Value = StrRecievedDate
             .Cells(i, "C").Value = StrSubject

End With
End Sub

上記のコードは機能のメインの部分だけを書いたものです。
管理表の管理項目として、受信日と件名しか記載していませんが、職場によって増やす必要があると考えます（処理日・担当者・その後の処理など）。

また、業務フローによって色んなエラーが想定され、エラーをカバーするコードが必要になります。
例えば、「Excel管理表を開いていない状態でマクロを実行してしまう」とエラーになります。
以下のコードを入れて、ExcelのアプリケーションまたはExcel管理表が開いていない場合にダイアログを出します。
（１）Excelそのものが開いているかをチェック

On Error GoTo ErrLabel
ErrLabel:
    MsgBox "メール管理表が開いていません"

（２）管理表が開いているかをチェック

Dim wb As Workbook, flag As Boolean
For Each wb In objExcel.Workbooks
　　If wb.Name =  "メール管理表.xlsm" Then
　　　flag = True
　　　Exit For
　　End If
　Next wb
　　If flag = False Then
　　　MsgBox ("管理表が開いていません。")
　　End
End If

以上です。