【OutlookVBA】メールを保存する時に日付を自動挿入する方法
Outlookメールの保存をしていますか？
私は重要なメールはmsg形式で保存するようにしています
そして、保存する時にタイトルの先頭に日付を付けているのですが、手間がかかるのでマクロ（OutlookVBA）で自動化することにしました。
ワンクリックで日付を付けて保存できるので、同じようにメール管理している方は真似してみてはどうでしょうか？
からタイトルの先頭に日付を付けるマクロ
タイトルの先頭に日付を付けるマクロは以下のようになります。
SAVE_FOLDER_PATHにファイルを保存フォルダへのパスを入れると使えます。
Sub SaveMailWithDate()
'タイトルの先頭に日付を付けてメールを保存（保存フォルダ固定）
Const SAVE_FOLDER_PATH = "C:\USER..." 'ファイルを保存するフォルダへのパス
Dim mllItem As Outlook.MailItem
Set mllItem = GetCurrentItem
If mllItem Is Nothing Then Exit Sub
Dim strName As String
strName = mllItem.Subject
'ファイル名に使用できない文字列を置換
Dim arrNG As Variant: arrNG = Array("/", ":", "*", "?", Chr(34), "<", ">", "|")
Dim arrOK As Variant: arrOK = Array("／", "：", "＊", "？", "＂", "＜", "＞", "｜")
Dim i As Long
For i = LBound(arrNG) To UBound(arrNG)
strName = Replace(strName, arrNG(i), arrOK(i))
Next
'日付を追加
strName = Format(Date, "yymmdd") & "-" & strName
'メールを保存
mllItem.SaveAs SAVE_FOLDER_PATH & "\" & strName & ".msg"
End Sub
Private Function GetCurrentItem() As Object
'選択中のメールアイテムオブジェクトを返す
On Error Resume Next
Select Case TypeName(Application.ActiveWindow)
Case "Explorer" 'Outlookのメインウィンドウがアクティブ
Set GetCurrentItem = Application.ActiveExplorer.Selection.Item(1)
Case "Inspector" 'Outlookのメールウィンドウがアクティブ
Set GetCurrentItem = Application.ActiveInspector.CurrentItem
End Select
End Function3点ほどポイントを説明します。
Set mllItem = GetCurrentItemメールアイテムはGetCurrentItemという自作関数を使って取得しています。
Outlookはメインウィンドウがアクティブな場合と、メールウィンドウがアクティブな場合でメールアイテムを取得する方法が異なります。
この違いに対応するため、 GetCurrentItem内でSelect Caseを使って処理を分岐させています。
'ファイル名に使用できない文字列を置換
Dim arrNG As Variant: arrNG = Array("/", ":", "*", "?", Chr(34), "<", ">", "|")
Dim arrOK As Variant: arrOK = Array("／", "：", "＊", "？", "＂", "＜", "＞", "｜")
Dim i As Long
For i = LBound(arrNG) To UBound(arrNG)
strName = Replace(strName, arrNG(i), arrOK(i))
Nextファイル名は日付+メールタイトルにするのですが、メールタイトルにファイル名として使えない文字が入っていた場合に文字列を全角へ置き換えしています。
Chr(34)については下の記事を参照してください。
https://yaromai.jp/double-quotation-chr/ '日付を追加
strName = Format(Date, "yymmdd") & "-" & strName日付の追加はこの箇所で行っています。
Format関数でyymmddの形式で日付を追記しています。年を2桁にしていますが、4桁にしたい場合はyyyymmddへ変えます。
保存フォルダをダイアログで選択したい場合
先ほどのプログラムは保存するフォルダを固定していますが、保存フォルダを毎回選択したい人に向けてもう1つプログラムを作成しました。
Sub SaveMailWithDate2()
'タイトルの先頭に日付を付けてメールを保存（保存フォルダをダイアログで選択)）
Dim mllItem As Outlook.MailItem
Set mllItem = GetCurrentItem
If mllItem Is Nothing Then Exit Sub
Dim strName As String
strName = mllItem.Subject
'ファイル名に使用できない文字列を置換
Dim arrNG As Variant: arrNG = Array("/", ":", "*", "?", Chr(34), "<", ">", "|")
Dim arrOK As Variant: arrOK = Array("／", "：", "＊", "？", "＂", "＜", "＞", "｜")
Dim i As Long
For i = LBound(arrNG) To UBound(arrNG)
strName = Replace(strName, arrNG(i), arrOK(i))
Next
'日付を追加
strName = Format(Date, "yymmdd") & "-" & strName
'保存フォルダをダイアログで選択（ExcelAppを利用）
Dim saveFolderPath As String
Dim xlApp As Object: Set xlApp = CreateObject("Excel.Application")
With xlApp.FileDialog(msoFileDialogFolderPicker)
If .Show = 0 Then MsgBox "キャンセルボタンが押されました": Exit Sub
saveFolderPath = .SelectedItems(1)
End With
Set xlApp=Nothing
'メールを保存
mllItem.SaveAs saveFolderPath & "\" & strName & ".msg"
End Sub
Private Function GetCurrentItem() As Object
'選択中のメールアイテムオブジェクトを返す
On Error Resume Next
Select Case TypeName(Application.ActiveWindow)
Case "Explorer" 'Outlookのメインウィンドウがアクティブ
Set GetCurrentItem = Application.ActiveExplorer.Selection.Item(1)
Case "Inspector" 'Outlookのメールウィンドウがアクティブ
Set GetCurrentItem = Application.ActiveInspector.CurrentItem
End Select
End Function '保存フォルダをダイアログで選択（ExcelAppを利用）
Dim saveFolderPath As String
Dim xlApp As Object: Set xlApp = CreateObject("Excel.Application")
With xlApp.FileDialog(msoFileDialogFolderPicker)
If .Show = 0 Then MsgBox "キャンセルボタンが押されました": Exit Sub
saveFolderPath = .SelectedItems(1)
End With
Set xlApp=Nothing先ほどのプログラムと異なっているのはこの部分です。
この部分でダイアログを表示して、保存フォルダを選択できるようにしています。
ダイアログを表示するために、Excelアプリケーションを利用しています。
マクロをボタン登録する方法
名前を付けて保存は何回も行う動作なので、マクロをボタン登録するのがオススメです。
OutlookではExcelのようにフォームコントロールがないため、私はクイックアクセスツールバーに登録しています。
画像のように「その他のコマンド」⇒「マクロ」と進むとマクロをクイックアクセスツールバーに登録できます。
クイックアクセスツールバーに登録して、ポチっと名前を付けて保存をやってみてください。
