こんにちは、くのへ@MasazaneKunoheです。
以前作ったけど記事化していないコードあったので投稿します。

多くの場面で「依頼メール」を作成しますよね？
しかし、「依頼しっぱなし」ということはありませんか？

依頼は必ずフォローすべきです。フォローしなくてよい作業なら依頼しない方がよいです。
また、フォローしない人の作業は後回しにされます。
悪いな、と思うかもしれませんが、相手も給料を貰って仕事しているプロであれば、業務を遂行する責任があることを念頭に置きましょう。毅然とする姿勢がみんなの信頼感を生みます。

しかし、人間である以上、思わずフォローを忘れることはあり得ます。
そこで、依頼メールを発信したら、自動的にフォロー作業をタスクに登録できたら便利です。
更に、そのタスクの中に、フォローメールの下書きができていたら最高です。

そんな自分の欲望を形にしたのが、今回のコードです。

依頼メールのフォロー作業＆フォローメールをタスク登録

今回のコードは「イベントマクロ」を使って、件名が【依頼】から始まるメールを発信した時に、タスクにフォロー作業を登録します。
その時にフォローメールの下書きも一緒に添付資料として登録してしまいます。

イベントマクロなので、標準モジュールではなくThisOutlookSessionにコーディングしてください。
次のコードをOutlook VBEのThisOutlookSessionにコピペで動くと思います。

Private WithEvents mySentMails As Items '送信済みメールトレイのItems用変数


Private Sub Application_Startup()
'Outlook起動時に動作

'mySentMailsを送信済みメールトレイのItemsに設定
 Set mySentMails = GetNamespace("MAPI").GetDefaultFolder(olFolderSentMail).Items

End Sub



Private Sub mySentMails_ItemAdd(ByVal Item As Object)
'mySentMails（送信済みメールトレイのItems）が増えた時に動作

'【依頼】から始まるメールに対してタスク登録処理を起動
  If Left(Item.Subject, 4) = "【依頼】" Then
    If MsgBox("回答フォローをタスク登録しますか？", vbYesNo) = vbYes Then

      Call FollowTaskRegister(Item)

    End If
  End If

End Sub



Sub FollowTaskRegister(ByVal Item As Object)
'タスク登録マクロ本体

  Const STANDARD_FOLLOW_DAY = 7 '依頼日からフォローまでの標準期間
  Dim dateFollowDay As Date     'InputBoxで取得したフォロー日を代入する変数
  
'フォロー日を取得する。
'もしも日付データ以外が入力された場合はErrLabelに飛ばし、
'再入力する場合にはInputLabelに戻す。

InputLabel:
  On Error Resume Next
    'フォロー日を入力させる。デフォルト値は今日＋フォロー標準期間後とする。
    dateFollowDay = InputBox("フォロー日をyyyy/mm/dd形式で入力ください", "フォロー日入力", Date + STANDARD_FOLLOW_DAY)
    
    '型式不一致エラー（日付データではない場合）は再入力判断のためErrLabelへ飛ばす
    'なお型式不一致エラーの場合はErr.Numberが13となる特性を応用する
    If Err.Number = 13 Then GoTo ErrLabel
    
    'InputBoxでキャンセル時や空欄が入力された時はこのタスク登録はせずに終了させる
    If StrPtr(dateFollowDay) = 0 Then Exit Sub  'キャンセル時にマクロ終了
  On Error GoTo 0

'フォローメール下書きを作る
  Dim objWSH As Object
  Set objWSH = CreateObject("WScript.Shell")
  
  '返信下書きはVbaProject.OTMと同じフォルダに保管する。そのアドレスをstrPathに代入する
  Dim strPath As String
  strPath = objWSH.specialfolders(5) & "\Microsoft\Outlook\" & "FollowMail.msg"
  
  'フォローメールのメールアイテム作成
  Dim objFollowMail As Object
  Set objFollowMail = Item.ReplyAll

  objFollowMail.Body = "（フォロー）下記メールの件、ご回答頂きたくお願い致します。" & vbCrLf & vbCrLf & _
                      objFollowMail.Body
  objFollowMail.Subject = "フォロー：" & Item.Subject
  
  'フォローメールをVbaProject.OTMと同じフォルダに保管
  objFollowMail.SaveAs strPath
  
'タスクに登録する
'タスクの実施日（StartDateプロパティ）は先ほど入力したフォロー日とする。
'タスク本文には「[送信日時]に送ったメールのフォロー」と記述する。
  Dim objTask As Object
  Set objTask = CreateItem(olTaskItem)
  
  With objTask
  
    .Subject = "回答フォロー:" & Item.Subject
    .StartDate = dateFollowDay
    .Body = Item.SentOn & "に送ったメールのフォロー" & vbCrLf & vbCrLf
    .Attachments.Add strPath
    
  'タスクを登録する
    .Save
  
  End With

'オブジェクトをNothingしておく
  Set objTask = Nothing
  Set objWSH = Nothing
  Set objFollowMail = Nothing
  
Exit Sub
  
'日付データ入力時に日付データ以外が入力された時に再入力を確認する
ErrLabel:
  If MsgBox("日付データをyyyy/mm/dd形式で再入力ください。「いいえ」の場合タスク登録をキャンセルします（メールは送信されます）", vbYesNo) = vbYes Then
    GoTo InputLabel
  Else
    Exit Sub
  End If
    
End Sub

動作の様子

①件名が【依頼】から始まるメールを送信する

②すると、送信イベントが実行される。タスク登録要否確認メッセージが表示される。
（ここでは「はい」を選んだとする）

③フォロー日を入力する
　デフォルト値は今日＋規定期間（注）が記入される
　（ここではこのままOKを押したとする）
（注）規定期間：コードの「Const STANDARD_FOLLOW_DAY = 7」で設定した日数

④メールが送信される。タスクを見るとちゃんと登録されている。
（下記画像は予定表にタスクも表示させているところ。）

⑤生成されたタスクを開くと、タスクの内容が記述されている
　また、フォローメール下書きのmsgファイルが添付されている

⑥フォローメールの下書きを開くと、次のようにできています。
ただし、「タスクアイテムの添付ファイル」の状態で開かれているので、このメールは送信できません。
送信するためには、一度デスクトップに添付メールファイルを保存してから開くことで、送信できます。

解説

このコードは送信メールが「送信済みメールトレイ」に入った時をトリガーにして動作するようにしました。
次のようなプログラムになっています。

１．mySentMailsをイベントマクロに使う定数としてWithEventsステートメントで定義する。
２．Outlookの起動時に mySentMails を「送信済みメール」トレイのItemsとしてセットする
３．mySentMails（送信済みメールトレイのアイテム）のItemAddイベント（アイテムが増えた時）をトリガーとし、メール件名が【依頼】で始まる場合は、FollowTaskRegisterを呼び出す。
４． FollowTaskRegisterで次の５～８を処理する
５．フォロー日を取得する
６．フォローメール下書きを作る
７．タスクに登録する
８．オブジェクトをNothingしておく

これらのポイントを解説します。

１．mySentMailsをイベントマクロに使う定数としてWithEventsステートメントで定義する。

送信済みメールトレイのItemsを示すmySentMailsというオブジェクトをWithEventsステートメントで定義します。
なお、WithEventsステートメントはDimと同じように使えますが、WithEventsで定義した変数はイベントに応答するようになります。

コードの先頭にあるの部分です。

Private WithEvents mySentMails As Items '送信済みメールトレイのItems用変数

２．Outlookの起動時に mySentMails を「送信済みメール」トレイのItemsとしてセットする

次のコードで、Outlook起動時にmySentMailsを「送信済みメール」のItemsとしてセットしています。
このコードを書かないと、 mySentMails は「受信トレイ」「ゴミ箱」など、どのメールのItemsを指すのかがOutlookが認識できないため動作しません。

Private Sub Application_Startup()
'Outlook起動時に動作

'mySentMailsを送信済みメールトレイのItemsに設定
 Set mySentMails = GetNamespace("MAPI").GetDefaultFolder(olFolderSentMail).Items

End Sub

３．mySentMails（送信済みメールトレイのアイテム）のItemAddイベント（アイテムが増えた時）をトリガーとし、メール件名が【依頼】で始まる場合は、FollowTaskRegisterを呼び出す。

mySentMails（送信済みメールトレイのアイテム）のItemAddイベント（アイテムが増えた時）を使って、メールが送信された時を検知します。

そして、メール件名が【依頼】で始まる場合にFollowTaskRegisterサブプロシージャを呼び出します。

コードのこの部分です。

Private Sub mySentMails_ItemAdd(ByVal Item As Object)
'mySentMails（送信済みメールトレイのItems）が増えた時に動作

'【依頼】から始まるメールに対してタスク登録処理を起動
  If Left(Item.Subject, 4) = "【依頼】" Then
    If MsgBox("回答フォローをタスク登録しますか？", vbYesNo) = vbYes Then
      Call FollowTaskRegister(Item)
    End If
  End If

End Sub

mySentMailsは送信済みトレイのItemsを指しています（手順２）。
そのため、ItemAddイベント（：Itemが増えた時に動作）を使うと、メールが送信されたタイミングを検知できます。

ItemAddイベントは Itemという引数を取得できます。このItemは追加されたItemを指します。そのため、今回の場合は送信したメールを指すことになります。
そこで、If文とLeft関数を使ってItem.Subject（メールの件名）の頭４文字が【依頼】である場合はFoolowTaskRegisterサブプロシージャを呼び出すコードにしています。

なお、MsgBoxでタスク登録をするかどうかをYesNoで選択できるようにしています。

４． FollowTaskRegisterで次の５～８を処理する

先ほどの手順３の次のコードでFollowTaskRegisterサブプロシージャを呼び出しています。

Call FollowTaskRegister(Item) 

FollowTaskRegisterの内容は手順5～８で解説します。
ここで注目頂きたいのは、 FollowTaskRegisterを呼び出す際に、引数としてItemを渡しています。これで、FollowTaskRegisterサブプロシージャでも依頼メールを元にした処理を行うことができます。

５． フォロー日を取得する

次のコードで、フォロー日を取得しています。

  Const STANDARD_FOLLOW_DAY = 7 '依頼日からフォローまでの標準期間
  Dim dateFollowDay As Date     'InputBoxで取得したフォロー日を代入する変数
  
'フォロー日を取得する。
'もしも日付データ以外が入力された場合はErrLabelに飛ばし、
'再入力する場合にはInputLabelに戻す。

InputLabel:
  On Error Resume Next
    'フォロー日を入力させる。デフォルト値は今日＋フォロー標準期間後とする。
    dateFollowDay = InputBox("フォロー日をyyyy/mm/dd形式で入力ください", "フォロー日入力", Date + STANDARD_FOLLOW_DAY)
    
    '型式不一致エラー（日付データではない場合）は再入力判断のためErrLabelへ飛ばす
    'なお型式不一致エラーの場合はErr.Numberが13となる特性を応用する
    If Err.Number = 13 Then GoTo ErrLabel
    
    'InputBoxでキャンセル時や空欄が入力された時はこのタスク登録はせずに終了させる
    If StrPtr(dateFollowDay) = 0 Then Exit Sub  'キャンセル時にマクロ終了
  On Error GoTo 0

  
　　　　　　　　　　　　（中略）

  
'日付データ入力時に日付データ以外が入力された時に再入力を確認する
ErrLabel:
  If MsgBox("日付データをyyyy/mm/dd形式で再入力ください。「いいえ」の場合タスク登録をキャンセルします（メールは送信されます）", vbYesNo) = vbYes Then
    GoTo InputLabel
  Else
    Exit Sub
  End If

一見複雑ですが、ここの主要部は次のコードであり、dateFollowDay変数にInputBoxステートメントでフォロー日を入力させるためのコードです。
複雑そうに見えるのは、他は初期設定やエラー処理のためのコードです。

dateFollowDay = InputBox("フォロー日をyyyy/mm/dd形式で入力ください", "フォロー日入力", Date + STANDARD_FOLLOW_DAY)

まず、フォロー日の初期設定のため、定数 STANDARD_FOLLOW_DAY を設定しています。ここは各職場での文化があると思いますが、一般的には３日～２週間程度と思います。
本コードでは１週間を示す「7」にしました。

  Const STANDARD_FOLLOW_DAY = 7 '依頼日からフォローまでの標準期間

そして、次のコードがメイン処理部分です。

 On Error Resume Next
    'フォロー日を入力させる。デフォルト値は今日＋フォロー標準期間後とする。
    dateFollowDay = InputBox("フォロー日をyyyy/mm/dd形式で入力ください", "フォロー日入力", Date + STANDARD_FOLLOW_DAY)
    
    '型式不一致エラー（日付データではない場合）は再入力判断のためErrLabelへ飛ばす
    'なお型式不一致エラーの場合はErr.Numberが13となる特性を応用する
    If Err.Number = 13 Then GoTo ErrLabel
    
    'InputBoxでキャンセル時や空欄が入力された時はこのタスク登録はせずに終了させる
    If StrPtr(dateFollowDay) = 0 Then Exit Sub  'キャンセル時にマクロ終了
  On Error GoTo 0

このコードは前述の通りInputBoxでフォロー日を入力させるのがメインです。
ただし、日付データではない値が入力された場合やキャンセルされた場合は、エラーが出て処理が止まってしまいます。

そこで、まずはOn Error Resume Nextでエラーを無視させるようにします。

型不一致エラーが出た場合、「Err.Numberが13となる」という特性があり、If文でこの場合は再入力要否を確認させる「ErrLabel」まで飛ぶように処理します。ErrLabelおよび再入力処理は後述します。

キャンセルされた場合はエラーではなく、Err.Numberが13になることはありません。この場合は 「If StrPtr(dateFollowDay) = 0 Then Exit Sub」でタスク登録処理を停止させます。

最後にOn Error Resume Nextでエラーを無視する設定にしたものを解除するため、 「On Error GoTo 0 」とコーディングしています。これでエラー無視の設定が解除されます。

再入力させるための処理はErrLabelとInputLabelにGoToステートメントで飛ばすことで実装しました。次の部分です。

InputLabel:

  On Error Resume Next

　　　　　　　　　　    （中略）

    If Err.Number = 13 Then GoTo ErrLabel
    
  On Error GoTo 0

  
　　　　　　　　　　　　（中略）

  
'日付データ入力時に日付データ以外が入力された時に再入力を確認する
ErrLabel:
  If MsgBox("日付データをyyyy/mm/dd形式で再入力ください。「いいえ」の場合タスク登録をキャンセルします（メールは送信されます）", vbYesNo) = vbYes Then
    GoTo InputLabel
  Else
    Exit Sub
  End If

Err.Numberが13（型式不一致エラー）だった場合、GoToステートメントでErrLabelまで飛ばします。
ErrLabelでは、If文で再入力するかどうかを選択させ、Yesであれば、InputLabelまで戻すようにしました。なお、もしもNoであればサブプロシージャを終了させることとしました。

なお、２週目はErr.Numberが13になっているため、無限ループするのでは？と思われる方もおられるかもしれませんが、On Error Resume Nextを通った際にErr.Numberの数値はリセットされるため問題ありません。

６．フォローメール下書きを作る

次のコードで、フォローメールの下書きを作成しています。

'フォローメール下書きを作る
  Dim objWSH As Object
  Set objWSH = CreateObject("WScript.Shell")
  
  '返信下書きはVbaProject.OTMと同じフォルダに保管する。そのアドレスをstrPathに代入する
  Dim strPath As String
  strPath = objWSH.specialfolders(5) & "\Microsoft\Outlook\" & "FollowMail.msg"
  
  'フォローメールのメールアイテム作成
  Dim objFollowMail As Object
  Set objFollowMail = Item.ReplyAll

  objFollowMail.Body = "（フォロー）下記メールの件、ご回答頂きたくお願い致します。" & vbCrLf & vbCrLf & _
                      objFollowMail.Body
  objFollowMail.Subject = "フォロー：" & Item.Subject
  
  'フォローメールをVbaProject.OTMと同じフォルダに保管
  objFollowMail.SaveAs strPath

WScript.ShellのSpecialFoldersメソッドを利用して各パソコンの「C:\Users\ユーザ名\AppData\Roaming」を取得しています。
SpecialFolders(X)のXに5を記載すると上記のアドレスを取得できます。

これに、 “\Microsoft\Outlook\”を加筆してOutlookマクロのデータファイルである「VbaProject.OTM」と同じフォルダにフォローメールの下書きを保存します。
フォローメール下書きのファイル名は 「FollowMail.msg」としました。手順7で、このファイルをタスクに添付します。

フォローメールは送信メールアイテムに対する「全員に返信」をベースに作成することとしました。
Outlookは自分の送信メールに対して「全員に返信」または「返信」を行うと、自分に対して返信するわけではなく、元のTo、CC宛先設定になるという機能があるため、これを活用します。

ただし、本文と件名にはフォローメールであることを加筆しました。

７．タスクに登録する

次のコードで、タスクに登録しています。

'タスクに登録する
'タスクの実施日（StartDateプロパティ）は先ほど入力したフォロー日とする。
'タスク本文には「[送信日時]に送ったメールのフォロー」と記述する。
  Dim objTask As Object
  Set objTask = CreateItem(olTaskItem)
  
  With objTask
  
    .Subject = "回答フォロー:" & Item.Subject
    .StartDate = dateFollowDay
    .Body = Item.SentOn & "に送ったメールのフォロー" & vbCrLf & vbCrLf
    .Attachments.Add strPath
    
  'タスクを登録する
    .Save
  
  End With

CreateItemでタスクを作成しています。
タスクアイテムオブジェクトのStartDateプロパティに手順5で入力させたフォロー日を代入しています。
また、タスクの本文にメールの送信日時を記入させるようにしています。ここで、メールの送信日時はSentOnプロパティとして登録されているため、これを抽出しています。

添付資料として、手順6で作成したフォローメール下書きを添付するため、タスクのAttachmentsオブジェクトにAddメソッドを使っています。

ここまで一通りタスクアイテムのプロパティに対して設定ができたところで、Saveメソッドでタスクとして登録保存しています。

８．オブジェクトをNothingしておく

最後にオブジェクト類をNothingしておきます。 残データにより思わぬ動作が起こることを防止するためです。

'オブジェクトをNothingしておく
  Set objTask = Nothing
  Set objWSH = Nothing
  Set objFollowMail = Nothing
  
Exit Sub

なお、このNothingの後にErrLabelが来ますが、コード自体はここで終了なので、Exit Subでサブプロシージャを終了させています。

（補足説明）

なお、今回はmySentMails_ItemAddイベントを使いましたが、Application_ItemSendイベントを使っても類似のコードを実装できます。
ただし、Application_ItemSendイベントは「送信するとき」であり、メールがまだ送信済みになっていないため、ReplyAllメソッドが使えません。このコードだと「送信後」に動くため、ReplyAllメソッドを使うことができるため、このイベントで実装しました。

コードがなかなかボリュームがあるため、やや長めのコードになりました。
このコードもかなり便利なので、ぜひ使ってみてください。

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

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