[Outlook VBA]定型メールから予定表アイテムを自動作成

やりたいこと

アカウントの期限切れ通知のメールが来ているのに、適当に受け流していたら仕事が忙しく後回しにしていたら期限が切れてしまって大変だったので、通知メールからVBAで予定表に自動転記することにしました。

仕様

期限切れ通知の定型メール仕様

• 配信元メールアドレス
  • [e-mail] (固定)
• メール件名
  • アカウント有効期限切れ事前通知 (ユーザ名)
• メール本文のフィールド表記
  • フィールド名：内容
    • 例) 有効期限：2021/12/1

作成する予定表アイテム仕様

• 件名
  • アカウント有効期限
• 場所
  • https://hogehoge.com/
• 本文
  • メール本文
• 開始日
  • メール本文中の[有効期限]フィールド
  • 終日イベントとして作成
• アラーム
  • 有効期限直近の営業日
• 重要度
  • 高

その他の仕様

• アラートメッセージ
  • 通知メールを受信した日が、有効期限直近の営業日から3日以内だった場合、メッセージボックスを表示
• 営業日
  • 土曜日・日曜日でないこと
  • 分類が[祝日]の予定が登録されていないこと
  • 分類が[休暇]で終日イベントの予定が登録されていないこと
• メールの重複
  • 同じ期限日でメールが再送された場合、登録済みの予定を削除して再登録する

動作環境

• Outlook2016
  たぶんもっと前のバージョンでも動作します。

設定方法

1. [開発]タブから[Visual Basic]を選択し、Visual Basic for Applicationsを起動する。
2. 左側[プロジェクト]から[ThisOutlookSession]をダブルクリックし、VbaProject.OTM - ThisOutlookSession(コード)を開く。
3. 以下のソースをコピー&ペーストし、Visual Basic for Applicationを終了する。

※[開発]タブが表示されていない場合、以下の方法で表示する。

• [ファイル]-[オプション]でOutlookのオプションを開く。
• 左側から[リボンのユーザー設定]を選択し、右側[リボンのユーザー設定]でメインタブ[開発]にチェックを入れる。

ソース

'メール受信時実行
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    ' 受信メール
    Dim objMail As Object
    Set objMail = Session.GetItemFromID(EntryIDCollection)

    If objMail.MessageClass = "IPM.Note" Then
        ' メッセージアイテムのみ処理
    
        If Not (objMail.Subject Like "アカウント有効期限切れ事前通知*" And objMail.Sender.Address = "[e-mail]") Then
            ' アカウント有効期限切れ事前通知メールのみ処理する
            Exit Sub
        End If

        ' メッセージ
        Dim strMsg As String
        
        ' 有効期限
        Dim expDate As Date

        ' 本文から有効期限を取得
        Dim strExpDate As String
        strExpDate = GetField(objMail.Body, "有効期限：")

        If IsDate(strExpDate) Then
            expDate = CDate(strExpDate)
        Else
            ' 有効期限が取得できなかった場合、メッセージを表示して終了
            strMsg = "アカウント有効期限切れ事前通知メールを受信しましたが、有効期限が取得できなかったため予定を登録できませんでした。" & vbCrLf & _
                     "本文を確認してください。" & vbCrLf & _
                     "メールを表示しますか？"
            
            If MsgBox(strMsg, vbYesNo + vbCritical) = vbYes Then
                objMail.Display
            End If
            
            Exit Sub
        End If
        
        ' 直近の営業日
        Dim recentWorkday As Date
        ' 有効期限から直近の営業日を取得
        recentWorkday = getRecentWorkday(expDate)
    
        ' リマインダ時間
        Dim reminderMin As Long
        ' 直近の営業日付までの分数を指定
        reminderMin = DateDiff("n", recentWorkday, expDate)
        
        ' 取得した情報で予定表アイテムを作成
        Dim objAppt As AppointmentItem
        Set objAppt = Application.CreateItem(olAppointmentItem)
        With objAppt
            .Subject = "アカウント有効期限" ' 件名
            .Location = "https://hogehoge.com/account/"
            .Body = objMail.Body ' 本文(元のメール本文)
            .Start = expDate ' 開始日(有効期限)
            .End = DateAdd("d", 1, expDate) ' 終了日(有効期限+1日)
            .AllDayEvent = True ' 終日イベント
            .ReminderSet = True ' リマインダ
            .ReminderMinutesBeforeStart = reminderMin ' リマインダ表示時間(有効期限から直近の営業日)
            .Importance = olImportanceHigh ' 重要度"高"
        End With
        
        ' 重複するアイテムがある場合、削除してから登録
        Dim duplicateAppt As AppointmentItem
        Set duplicateAppt = getDuplicateAppt(objAppt)
        If Not (duplicateAppt Is Nothing) Then
            duplicateAppt.Delete
        End If
        
        objAppt.Save
        
        If DateDiff("d", Date, recentWorkday) <= 3 Then
            ' 有効期限直近の営業日が3日以内の場合、アラートメッセージを表示
            Dim lastDay As Long
            lastDay = DateDiff("d", Date, expDate)
            strMsg = "アカウント有効期限まであと " & lastDay & "日です。" & vbCrLf & _
                     "有効期限を更新しますか？" & vbCrLf & _
                     "[はい]をクリックするとアカウント更新ページに遷移します。"
    
            If MsgBox(strMsg, vbYesNo + vbExclamation) = vbYes Then
                '「はい」の場合、IEでアカウント更新ページを起動
                Shell "C:\Program Files\Internet Explorer\iexplore.exe https://hogehoge.com/account/", vbNormalFocus
            End If
        End If
    End If

End Sub

' 文章内から指定された情報を取得する
Private Function GetField(strMessage As String, strField As String)
    Dim i As Long
    i = InStr(strMessage, strField)
    
    Dim strValue As String
    If i > 0 Then
        ' 指定された文字列が存在した場合、文字列以降改行までを取得
        strValue = Mid(strMessage, i + Len(strField))
        strValue = Left(strValue, InStr(strValue, vbCrLf) - 1)
        
        ' 戻り値に取得した文字列を設定
        GetField = Trim(strValue)
    Else
        ' 指定された文字列が存在しない場合、戻り値に空文字を設定
        GetField = ""
    End If

End Function

' 直近の営業日を取得(土日でない・祝日に登録されていない・終日の休暇に登録されていない日)
Private Function getRecentWorkday(objDate As Date)
    ' Name Space
    Dim myNamespace As NameSpace
    Set myNamespace = GetNamespace("MAPI")
    
    ' 自分のカレンダーアイテムフォルダ
    Dim myFolder As Outlook.Folder
    Set myFolder = myNamespace.GetDefaultFolder(olFolderCalendar)
    
    ' カレンダーアイテム
    Dim myItems As Outlook.Items
    Set myItems = myFolder.Items
    
    ' 定期的な予定を含める
    myItems.IncludeRecurrences = True
    ' 開始日でソート
    myItems.Sort "[start]"
    
    ' 休日判定フラグ
    Dim isHoliday As Boolean
    isHoliday = True
    
    ' 戻り値に指定日を設定
    getRecentWorkday = objDate
        
    Dim apptItem As Outlook.AppointmentItem
    While isHoliday
        ' 休日判定フラグがFalseになるまでチェックを繰り返す
        While Weekday(getRecentWorkday) = vbSunday Or Weekday(getRecentWorkday) = vbSaturday
            ' 土日だった場合、戻り値を前日に移動
            getRecentWorkday = DateAdd("d", -1, getRecentWorkday)
        Wend
        
        ' 抽出文字列
        Dim strFilter As String
        strFilter = "[Start] = '" & Format$(getRecentWorkday, "mm/dd/yyyy hh:mm AMPM") & "'"
        ' 全予定表アイテムから対象日付で抽出
        Set myItems = myItems.Restrict(strFilter)
        
        For Each apptItem In myItems
            ' 対象日付で抽出したアイテムを検索
            If Item.Start = getRecentWorkday And (Item.Categories = "祝日" Or (Item.Categories = "休暇" And Item.AllDayEvent = True)) Then
                ' 祝日または終日の休暇だった場合、戻り値を前日に移動して再度チェックを実行
                getRecentWorkday = DateAdd("d", -1, getRecentWorkday)
                GoTo CONTINUE
            End If
        Next apptItem
        
        ' 土日・祝日・休暇でない場合、休日判定フラグをFalseにしてチェックを終了
        isHoliday = False

CONTINUE:
    Wend

End Function

' 重複する予定表を取得
Private Function getDuplicateAppt(objAppt As AppointmentItem)
    ' Name Space
    Dim myNamespace As NameSpace
    Set myNamespace = GetNamespace("MAPI")
    
    ' 自分のカレンダーアイテムフォルダ
    Dim myFolder As Outlook.Folder
    Set myFolder = myNamespace.GetDefaultFolder(olFolderCalendar)
    
    ' カレンダーアイテム
    Dim myItems As Outlook.Items
    Set myItems = myFolder.Items
    
    ' 開始日でソート
    myItems.Sort "[start]"
        
    ' 抽出文字列
    Dim strFilter As String
    strFilter = "[Start] = '" & Format$(objAppt.Start, "mm/dd/yyyy hh:mm AMPM") _
    & "' AND [End] = '" & Format$(objAppt.End, "mm/dd/yyyy hh:mm AMPM") & "'"
    ' 全予定表アイテムから対象日付で抽出
    Set myItems = myItems.Restrict(strFilter)
    
    ' 戻り値にNothingを設定
    Set getDuplicateAppt = Nothing
    
    Dim apptItem As Outlook.AppointmentItem
    For Each apptItem In myItems
        ' 抽出したアイテムを検索
        If apptItem.Subject = objAppt.Subject Then
            ' Subjectが一致した場合、重複として戻り値に予定表アイテムを設定して返却
            Set getDuplicateAppt = apptItem
            
            Exit For
        End If
    Next apptItem

End Function

解説

Application_NewMailEx(ByVal EntryIDCollection As String)

メールを受信した際に呼び出されるイベントです。
Session.GetItemFromID(EntryIDCollection)で、受信したメールオブジェクトを取得できます。
Application_NewMailというイベントもありますが、こちらはOutlook2002以前でApplication_NewMailExが存在しなかった頃のイベントで、このイベントでは上記のような方法で受信したメールオブジェクトが取得できないため、自力で受信メールを検索する必要がありました。
従って、Application_NewMailExが追加された現在では、Application_NewMailイベントを利用する意味はありません。

Exchange環境下での動作

Application_NewMailExのExchange環境下での仕様

Application_NewMailExイベントは新規メール受信時に動作しますが、Exchange環境ではOutlookが起動していなくてもサーバ上でメールが受信された時点でイベントが発生してしまいます。
このタイミングでOutlookが起動していない場合、当然ですがVBAは実行されませんので、端末を落としている夜間や休日に受信したメールは処理することができません。

Application.NewMailEx イベント (Outlook) | Microsoft Docs

対策として仕分けルールでVBAスクリプトを実行する方法がありますが、セキュリティの関係上レジストリを変更する必要があります。

OUTLOOK VBA 自動仕分けウィザードでカスタムコードを使うときはレジストリを変更する必要がある - Qiita

上記を適用した上で、仕分けルールでの実行に対応したスクリプトのソースコードが以下となります。

ソース

' 仕分けルールからスケジュールを作成
Public Sub CreateApptByMail(ByRef objMail As MailItem)
            
    If Not (objMail.Subject Like "アカウント有効期限切れ事前通知*") Then
        ' アカウント有効期限切れ事前通知メールのみ処理する
        Exit Sub
    End If

    ' メッセージ
    Dim strMsg As String

    ' 有効期限
    Dim expDate As Date
    
    ' 本文から有効期限を取得
    Dim strExpDate As String
    strExpDate = GetField(objMail.Body, "有効期限：")
    
    If IsDate(strExpDate) Then
        expDate = CDate(strExpDate)
    Else
        ' 有効期限が取得できなかった場合、メッセージを表示して終了
        strMsg = "アカウント有効期限切れ事前通知メールを受信しましたが、有効期限が取得できなかったため予定を登録できませんでした。" & vbCrLf & _
                 "本文を確認してください。" & vbCrLf & _
                 "メールを表示しますか？"
        
        If MsgBox(strMsg, vbYesNo + vbCritical) = vbYes Then
            ' 「はい」の場合、メールを表示
            objMail.Display
        End If
        
        Exit Sub
    End If
    
    ' 直近の営業日
    Dim recentWorkday As Date
    ' 有効期限から直近の営業日を取得
    recentWorkday = getRecentWorkday(expDate)

    ' リマインダ時間
    Dim reminderMin As Long
    ' 直近の営業日付までの分数を指定
    reminderMin = DateDiff("n", recentWorkday, expDate)
    
    ' 取得した情報で予定表アイテムを作成
    Dim objAppt As AppointmentItem
    Set objAppt = Application.CreateItem(olAppointmentItem)
    With objAppt
        .Subject = "アカウント有効期限" ' 件名
        .Location = "https://hogehoge.com/account/"
        .Body = objMail.Body ' 本文(元のメール本文)
        .Start = expDate ' 開始日(有効期限)
        .End = DateAdd("d", 1, expDate) ' 終了日(有効期限+1日)
        .AllDayEvent = True ' 終日イベント
        .ReminderSet = True ' リマインダ
        .ReminderMinutesBeforeStart = reminderMin ' リマインダ表示時間(有効期限から直近の営業日)
        .Importance = olImportanceHigh ' 重要度"高"
    End With
    
    ' 重複するアイテムがある場合、削除してから登録
    Dim duplicateAppt As AppointmentItem
    Set duplicateAppt = getDuplicateAppt(objAppt)
    If Not (duplicateAppt Is Nothing) Then
        duplicateAppt.Delete
    End If
    
    objAppt.Save
    
    If DateDiff("d", Date, recentWorkday) <= 3 Then
        ' 有効期限直近の営業日が3日以内の場合、アラートメッセージを表示
        Dim lastDay As Long
        lastDay = DateDiff("d", Date, expDate)
        strMsg = "アカウント有効期限まであと " & lastDay & "日です。" & vbCrLf & _
                 "有効期限を更新しますか？" & vbCrLf & _
                 "[はい]をクリックするとアカウント更新ページに遷移します。"

        If MsgBox(strMsg, vbYesNo + vbExclamation) = vbYes Then
            '「はい」の場合、IEでアカウント更新ページを起動
            Shell "C:\Program Files\Internet Explorer\iexplore.exe https://hogehoge.com/account/", vbNormalFocus
        End If
    End If

End Sub

解説

サブルーチンの形式は、Public sub サブルーチン名(ByRef 引数名 As MailItem/MeetingItem)で、ThisOutlookSessionを含む任意のモジュールに記述できます。
Application_NewMailExとの大きな違いは、引数としてMailItemまたはMeetingItem型のオブジェクトが直接渡されてくるため、EntryIdから処理対象のアイテムを取得する手間が省ける点です。
また、仕分けルールから実行するため、仕分けルールで指定可能なフィルタリング条件(差出人が[e-mail]だった場合のみ実行、など)はVBAには記述せず仕分けルール側に任せることができます。というか、VBAの実行自体を抑制できるのでそうした方がいいです。

仕分けルールの作成

• Outlookの[ホーム]タブ-[移動]-[ルール]-[仕分けルールの作成]をクリック
• [仕分けルールの作成]で[詳細オプション]をクリック
• 以下の内容で仕分けルールを作成する
  • 条件
    • このコンピューターで送受信を行った場合のみ
    • [差出人]が[e-mail]の場合
  • 処理
    • スクリプトを実行する
      • プロジェクト名.モジュール名.CreateApptByMail

参考にしたサイト

受信したメールをもとに予定表アイテムを作成するマクロ
ある期間内の予定のうちで件名に特定の語を含むものを予定表で検索する
Exchange/Office 365/Outlook.com 環境で NewMailEx が動作しない場合がある | Outlook 研究所
Outlookの仕分けルールからスクリプトを実行しメール転送する方法 - エク短｜Extan.jp
OUTLOOK VBA 自動仕分けウィザードでカスタムコードを使うときはレジストリを変更する必要がある - Qiita