特定の文字列を含む予定の数日前にメールを自動送信するスクリプト


コメントにて以下のご要望をいただきました。


お世話になっております。outlookについて色々調べているうちにこちらにたどり着きました。以下のようなマクロを作成することは難しいでしょうか??何卒ご検討よろしくお願いいたします。
OUTLOOK2016を使用しております。

【やりたいこと】
  現在会社で休暇予定をOUTLOOKのスケジュールに反映したあと、休暇の数日前にメールで関係者宛に休暇連絡をしておりますが、メール発信部分を自動化したいと考えております。

【具体的なマクロの機能】
スケジュールの件名に特定の文字列(例えば「休暇」)を含んだ予定を反映すると、該当スケジュールの5日前に指定した宛先(予め指定しておいたメーリングリスト)にメールを自動発信する


予定を反映した際にその 5 日前にメールを送信するように設定するとなると、メールの遅延送信でスケジュールするという方法が考えられます。
しかし、遅延送信を行う場合は Outlook を起動し続けていなければならず、予定の変更や削除にも対応できません。

そこで、このご要望について以下のように置き換えてみました。

スクリプトを実行した日の 5 日後に特定の件名を含む予定があった場合に、その予定の情報を指定した宛先に送信する。

メールの自動発信についてはタスク スケジューラーによりスクリプトを定期的に実行することで実現できます。
このスクリプトで 5 日後に特定の件名を含む予定を検索し、見つかったらその件名や日付をメールで送信します。
スクリプトは以下のようになります。

' ここをトリプルクリックでスクリプト全体を選択できます。

' 検索するキーワード
Const KEYWORD = "休暇"
' n 日前の設定
Const DATE_BEFORE = 5
' 通知メールの送信先
Const NOTIFY_TO = "notify@example.com"
' 通知メールの件名
Const NOTIFY_SUBJECT = "休暇予定連絡"
' 通知メールの本文
Const NOTIFY_BODY = "以下の日程で休暇をいただきます。"
' Outlook の定数設定
Const olFolderCalendar = 9
Const olMailItem = 0
'
Dim appOlk 'As Outlook.Application
Dim fldCalendar 'As Folder
Dim colItems 'As Items
Dim dtStart 'As Date
Dim dtEnd 'As Date
Dim apptHol 'As AppointmentItem
Dim strBody 'As String
' Outlook の Application オブジェクトを取得
Set appOlk = CreateObject("Outlook.Application")
' 既定の予定表フォルダーを取得
Set fldCalendar = appOlk.Session.GetDefaultFolder(olFolderCalendar)
' 予定表のアイテム一覧を取得
Set colItems = fldCalendar.Items
' 予定アイテムを開始日でソート
colItems.Sort "[開始日]"
' 繰り返しのアイテムを展開
colItems.IncludeRecurrences = True
' n 日後の定義
dtStart = CDate(FormatDateTime(DateAdd("d", DATE_BEFORE, Now), vbShortDate))
dtEnd = CDate(FormatDateTime(DateAdd("d", DATE_BEFORE + 1, Now), vbShortDate))
' n 日後を含む予定を検索
Set apptHol = colItems.Find("[開始日] < '" & dtEnd & "' and [終了日] > '" & dtStart & "'")
strBody = ""
' 検索されるアイテムがなくなるまで繰り返す
While Not apptHol Is Nothing
     With apptHol
         ' 条件が一致する予定かどうかの確認
         If .Start < dtEnd And .End > dtStart And InStr(.Subject, KEYWORD) > 0 Then
             ' 予定の件名と開始日を本文に追記
             strBody = strBody & .Subject & vbTab & .Start
             If .Start < DateAdd("d", -1, .End) Then
                 ' 2 日以上にまたがる場合は終了日も追記
                 strBody = strBody & "-" & DateAdd("d", -1, .End)
             End If
             ' 改行を追記
             strBody = strBody & vbCrLf
         End If
     End With
     ' 次のアイテムを検索
     Set apptHol = colItems.FindNext
Wend
' 予定が見つかっていたら通知メール作成
If strBody <> "" Then
     Dim msgNotify 'As MailItem
     ' メールアイテムを作成
     Set msgNotify = appOlk.CreateItem(olMailItem)
     With msgNotify
         ' 宛先、件名、本文を設定し、送信
         .To = NOTIFY_TO
         .Subject = NOTIFY_SUBJECT
         .Body = NOTIFY_BODY & vbCrLf & strBody
         .Send
     End With
End If

コメントを残す

以下に詳細を記入するか、アイコンをクリックしてログインしてください。

WordPress.com ロゴ

WordPress.com アカウントを使ってコメントしています。 ログアウト /  変更 )

Google フォト

Google アカウントを使ってコメントしています。 ログアウト /  変更 )

Twitter 画像

Twitter アカウントを使ってコメントしています。 ログアウト /  変更 )

Facebook の写真

Facebook アカウントを使ってコメントしています。 ログアウト /  変更 )

%s と連携中