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

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


お世話になっております。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

広告

返信の際に組織外のアドレスを Bcc に移動するマクロ

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


管理人様

「組織外への送信の際にアドレスをすべて Bcc に移動するマクロ」に類似した機能となりますが、返信メール作成時に、自動的に組織外のアドレスをBCCに移動することはできないでしょうか。
  「組織外への送信の際にアドレスをすべて Bcc に移動するマクロ」では送信ボタンをクリックしてから自動的に宛先がBCCに移動しますが、できれば、返信メール作成時にBCCに移動していることを確認したうえで、送信ボタンをクリックしたいと考えています。

よろしくお願いいたします。


返信メール作成時に組織外のアドレスを Bcc に移動するには、返信処理自体を行うマクロを作るのが簡単なものとなります。
組織外への送信の際にアドレスをすべて Bcc に移動するマクロでは社外あての送信の際に自分以外のすべてのアドレスを Bcc に移動するという条件だったため、ループが二つありましたが、単に組織外のアドレスを Bcc に移動するだけならループは一つになります。
マクロは以下の通りです。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub ReplyWithMovingExternalAddresToBcc()
     Const MY_DOMAIN = "*@example.com" ' 自組織のドメイン名を指定。@ の前に * を付ける
     Dim msgReply As MailItem
     Dim objRec As Recipient
     ' 現在表示しているアイテムに返信
     If TypeName(ActiveWindow) = "Inspector" Then
         Set msgReply = ActiveInspector.CurrentItem.ReplyAll
     Else
         Set msgReply = ActiveExplorer.Selection(1).ReplyAll
     End If
     ' 組織外の受信者が存在するかどうかの確認
     For Each objRec In msgReply.Recipients
         If objRec.AddressEntry.Type <> "EX" Then
             ' 組織外の受信者だったら
             If Not objRec.Address Like MY_DOMAIN Then
                 ' Bcc に移動
                 objRec.Type = olBCC
             End If
         End If
     Next
     ' 返信メッセージを表示
     msgReply.Display
End Sub

マクロの登録方法やメニューへの追加について

Outlook 2016/2013/2010 の累積的な修正プログラム 2019 年 4 月分がリリース

4/2 に Outlook 2016/2013/2010 の累積的な修正プログラムがリリースされました。

以下は各製品のそれぞれの KB へのリンクです。

Office 2016

Outlook 2016 の修正

Outlook 2016 (KB4464502) は、2019 年 4 月 2日の更新プログラム
3 件の機能追加と不具合修正が行われています。

Microsoft Exchange Add-inの修正

Office 2016 (KB4462239) は、2019 年 4 月 2日の更新プログラム
1 件の Outlook に関する不具合の修正が行われています。

Office 2016 共通コンポーネントの修正

Office 2016 (KB4462116) は、2019 年 4 月 2日の更新プログラム
1 件の Outlook にアドインに関する不具合の修正が行われています。

Office 2013

Outlook 2013 の修正

Outlook 2013 (KB4464507) は、2019 年 4 月 2日の更新プログラム
2 件の機能追加と 1 件の不具合修正が行われています。

Office 2010

Outlook 2010 の修正

Outlook 2010 (KB3114559) は、2019 年 4 月 2日の更新プログラム
1 件の機能追加が行われています。

一定時間内に特定のキーワードを含むメールを複数受信したらアラームを表示するマクロ

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


管理人様

はじめまして。コメント失礼致します。
https://outlooklab.wordpress.com/2018/02/10/
以前上記で記載いただいたマクロに関しまして、条件を「一定時間内にメール本文に同じ文言が含まれるメールを複数受信したらポップアップ(通知)等をあげる」という条件のマクロの構文を伺ってもよろしいでしょうか?


マクロでポップアップ表示を行った場合、そのポップアップを閉じるまでは他のマクロが実行できない状態となってしまいます。
ポップアップ以外の通知方法としては Outlook のアラームを使用する方法がありますので、一定期間内に特定のキーワードを含むメールを指定数受信したら、最後に受信したメールにフラグを付けてアラームを表示するようなマクロにしてみました。

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

Dim g_strLastReceived As String
'
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
     Dim objItem As Object ' MailItem
     '
     Set objItem = Session.GetItemFromID(EntryIDCollection)
     '
     If objItem.MessageClass = "IPM.Note" Then
         FindAndNotice objItem
     End If
End Sub
'
Private Sub FindAndNotice(ByVal objItem As MailItem)
     ' 監視するキーワード
     Const MONITOR_KEYWORD = "test"
     ' 通知するメール数の閾値
     Const MAX_MAILS = 10
     ' 監視する時間 (分単位)
     Const INTERVAL_MIN = 10
     ' 通知メールの本文
     Const ALERT_FLAG_NAME = "メールを " & INTERVAL_MIN & _
         " 分以内に " & MAX_MAILS & " 件受信しました。 """
     Dim arrDate() As String
     Dim dtStart As Date
     Dim strStart As String
     Dim i As Integer
     ' メールがキーワードを含まなければ終了
     If InStr(objItem.Body, MONITOR_KEYWORD) = 0 Then
         Exit Sub
     End If
     ' 受信日時の配列を生成
     arrDate = Split(g_strLastReceived, ";")
     If UBound(arrDate) < 0 Then
         g_strLastReceived = objItem.ReceivedTime
     ElseIf UBound(arrDate) < MAX_MAILS - 1 Then
         g_strLastReceived = g_strLastReceived & ";" & objItem.ReceivedTime
     Else
         g_strLastReceived = ""
         ' 監視の開始時間を算出
         dtStart = DateAdd("n", -INTERVAL_MIN, Now)
         If CDate(arrDate(0)) >= dtStart Then
             ' 配列の先頭が監視の開始時間よりも後ならフラグを設定
             objItem.MarkAsTask olMarkToday
             objItem.FlagRequest = ALERT_FLAG_NAME
             ' フラグのアラームを現在時刻にして直ちにアラーム表示
             objItem.ReminderTime = Now
             objItem.TaskDueDate = Now
             objItem.ReminderSet = True
             objItem.Save
         Else
             ' 監視期間中に一定量受信していなければ、受信日時を追加
             For i = 1 To UBound(arrDate)
                 g_strLastReceived = g_strLastReceived & arrDate(i) & ";"
             Next
             g_strLastReceived = g_strLastReceived & objItem.ReceivedTime
         End If
     End If
End Sub

マクロの登録方法やメニューへの追加について

転送の際に自分以外のアドレスを返信先として追加するマクロ

転送の際に元の差出人を返信先として設定するマクロのコメントにて以下のご要望をいただきました。


いろいろ試したのですが、惨敗したので質問させていただきます。
ここで公開されているマクロよりも、もっとシンプルなものが作りたいです。

メールを転送した際に、返信先のアドレスとして自分のアドレスが自動で登録されますが
  あるアドレス(例:hogehoge@example.com) も追加したいです。つまり、2つのアドレスが返信先アドレスとなります。
あるアドレスは固定値ですので、毎回同じ2つのアドレスが返信先に指定されることになります。

アカウント設定で追加できるようですが、会社のPCのためか、設定項目がありませんでした。
よろしくおねがいします。


返信先のアドレスは MailItem オブジェクトの ReplyRecipients プロパティの Add メソッドで追加できます。
既定では ReplyRecipients は空になっていますが、ここに返信先を指定すると差出人には返信されなくなるので、自分のアドレスも Session.CurrentUser.Address より取得して追加する必要があります。
マクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub ForwardWithReplyTo()
     ' 返信先に追加するアドレスの指定
     Const ADD_REPLY_TO = "test@example.com"
     Dim orgMail As MailItem
     Dim fwdMail As MailItem
     Dim newRecip As Recipient
     ' 現在表示中のメールを取得
     Set orgMail = ActiveInspector.CurrentItem
     ' 転送メールを作成
     Set fwdMail = orgMail.Forward
     ' 転送メールの返信先に自分のアドレスを追加
     Set newRecip = fwdMail.ReplyRecipients.Add(Session.CurrentUser.Address)
     newRecip.Resolve
     ' 転送メールの返信先にほかのアドレスを追加
     Set newRecip = fwdMail.ReplyRecipients.Add(ADD_REPLY_TO)
     newRecip.Resolve
     ' 転送メールを表示
     fwdMail.Display
End Sub

マクロの登録方法やメニューへの追加について

メールアドレスのリンクをクリックした際に宛先の表示名を自動的に連絡先のものに置き換えるマクロ

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


社内サイト内からメールアドレスリンクをクリックし新規メールを作成する際、表示名をアドレス帳の表示名に置き換えるマクロはありますか?

せっかくアドレス帳に入っているのに表示名がメールアドレスなので統一したいです。

よろしくお願い致します。


宛先の表示名を連絡先の表示名で置き換えるマクロは「返信メッセージで表示名をアドレス帳のものに置き換えるマクロ」や「送信済みアイテム フォルダの宛先を連絡先に表示名に置き換えるマクロ」として公開していますが、これらは返信時などに手動でマクロを実行する必要があります。
メールアドレスの リンク (mailto) をクリックした際に自動的に表示名の置き換えをするには、新規のメッセージ作成ウィンドウ (Inspector) が開かれた際に発生する NewInspector イベントを使用します。
このイベントは Inspectors というオブジェクトのものですが、このオブジェクトのイベントを処理するためには、あらかじめ Inspectors のイベントを処理するための変数を WithEvents というキーワード付きで定義しておき、Outlook の起動時に発生する Application_Startup イベントでその変数に Application.Inspectors を設定する必要があります。

マクロは以下のようになります。

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

' NewINspector イベントを受けるオブジェクト
Dim WithEvents myInspectors As Inspectors
' 起動時に実行されるイベント
Private Sub Application_Startup()
     Set myInspectors = Application.Inspectors
End Sub
' 新規のメッセージ作成ウィンドウ (Inspector) が開くときのイベント
Private Sub myInspectors_NewInspector(ByVal Inspector As Inspector)
     Dim objMail 'As MailItem
     Set objMail = Inspector.CurrentItem
     ' 送信前のメール アイテムを開いた場合だけ処理
     If objMail.MessageClass = "IPM.Note" And Not objMail.Sent Then
         ResolveAddressEx objMail
     End If
End Sub
' アドレス帳で名前解決を行うマクロ
Public Sub ResolveAddressEx(ByVal objMail As MailItem)
     Const PR_SMTP_ADDRESS = "http:" & "//schemas.microsoft.com/mapi/proptag/0x39FE001E"
     Dim objRecip As Recipient
     Dim objContact As ContactItem
     Dim objAddrList As AddressList
     Dim i As Integer
     Dim objAddrEntry As AddressEntry
     Dim cRecips As Integer
     Dim colAddress() As String
     Dim colName() As String
     Dim colType() As Integer
     Dim strEntryID As String
     '
     With objMail.Recipients
         ' あらかじめ名前解決を実行
         .ResolveAll
         cRecips = .Count
         ReDim colAddress(cRecips) As String
         ReDim colName(cRecips) As String
         ReDim colType(cRecips) As Integer
         For i = cRecips To 1 Step -1
             ' 受信者オブジェクトを取得
             Set objRecip = .Item(i)
             ' 受信者の情報を配列にコピー
             With objRecip.AddressEntry
                 If .Type = "SMTP" Then
                     colAddress(i) = objRecip.Address
                 Else
                     colAddress(i) = .PropertyAccessor.GetProperty(PR_SMTP_ADDRESS)
                 End If
             End With
             colName(i) = objRecip.Name
             colType(i) = objRecip.Type
             ' コピーした受信者を削除
             .Remove i
         Next
         '
         For i = 1 To cRecips
             Set objRecip = Nothing
             ' アドレス帳から受信者のアドレスを検索
             For Each objAddrList In Session.AddressLists
                 ' Outlook アドレス帳だけが検索対象
                 If objAddrList.AddressListType = olOutlookAddressList Then
                     For Each objAddrEntry In objAddrList.AddressEntries
                         ' アドレスが一致したらアドレス帳の情報を受信者に設定
                         If objAddrEntry.Address = colAddress(i) Then
                             Set objRecip = .Add(colAddress(i))
                             Set objRecip.AddressEntry = objAddrEntry
                             objRecip.Type = colType(i)
                             objRecip.Resolve
                             Exit For
                         End If
                     Next
                     ' 受信者が見つかったら For ループを脱出
                     If Not objRecip Is Nothing Then
                         Exit For
                     End If
                 End If
             Next
             ' 受信者が見つからなければ元の情報で追加
             If objRecip Is Nothing Then
                 If colName(i) <> colAddress(i) Then
                     Set objRecip = .Add(colName(i) & "<" & colAddress(i) & ">")
                 Else
                     Set objRecip = .Add(colAddress(i))
                 End If
                 objRecip.Type = colType(i)
             End If
         Next
         ' 名前解決の再実行
         .ResolveAll
     End With
End Sub

マクロの登録方法やメニューへの追加について

特定の文字列で始まる件名のメールを受信した際に、その受信日時と本文中のデータを Excel ファイルに保存するマクロ

Outlook マクロ・スクリプト インデックスのコメントにて以下のご要望をいただきました。


はじめまして

Inbox直下のサブフォルダーに特定の形式、同じアドレスから入ってくるオーダーメールが日に150件ほど届きます。
タイトル「特定の文字列+オーダー番号」
  本文
オーダー番号:*****
  顧客名:******
  電話番号:******

このオーダーメールが届く度に随時所定のExcelファイルに受信日時を含めて情報を書き出すマクロを作りたいと思っています。
  受信日時:A列
  顧客名:B列
Customer Name: C列
  電話番号:D列
※上書きではなく空いている行に積みあがっていくように

以下の2つとにたような形式でできるのではないかと思いますが、どうもうまくいきません。

・「特定の文字列を件名に含むメールを受信した際にその送信者アドレスと受信日時をExcelファイルまたはCSVファイルに保存するマクロ
・「決まった件名のメッセージを受信したら、データを CSV ファイルに保存するマクロ

お力添えを頂けましたら幸いです。


ご推察の通り、上記の二つのマクロを組み合わせることで、ご要望の動作をするマクロを作ることができます。
サンプルは以下の通りなのですが、Excel ファイルに書き出す内容としてオーダー番号がなく、顧客名と Customer Name は重複しているように思われたので、オーダー番号を B 列、顧客名を C 列に書き込むようにしました。

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

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
     SaveToExcel EntryIDCollection
End Sub
'
Private Sub SaveToExcel(ByVal EntryIDCollection As String)
     Const AUTO_SAVE_TITLE = "特定の文字列" ' 自動処理するメールの件名
     Const AUTO_SAVE_SENDER = "特定の差出人アドレス" ' 自動処理するメールの差出人アドレス
     Const EXCEL_FILE = "c:\orders\data.xlsx" ' データを保存する Excel ファイルの名前
     Dim i As Integer
     Dim arrEntryId
     Dim myMsg
     Dim stmCsv
     Set stmCsv = Nothing
     Set myMsg = Application.Session.GetItemFromID(EntryIDCollection)
     If myMsg.Subject Like AUTO_SAVE_TITLE & "*" And myMsg.SenderEmailAddress = AUTO_SAVE_SENDER Then
         Dim excBook As Object
         Dim excSheet As Object
         Dim iRow As Integer
         Dim strOrderNumber
         Dim strCustomerName
         Dim strTelephone
         ' Excel ファイルを取得
         Set excBook = GetObject(EXCEL_FILE)
         excBook.Windows(1).Activate
         ' 1 つ目のワークシートを取得
         Set excSheet = excBook.Worksheets(1)
         ' あいている行を検索
         iRow = 2
         While excSheet.Cells(iRow, 1) <> ""
             iRow = iRow + 1
         Wend
         ' 本文からデータを取得
         strOrderNumber = GetText("オーダー番号:", myMsg.Body)
         strCustomerName = GetText("顧客名:", myMsg.Body)
         strTelephone = GetText("電話番号:", myMsg.Body)
         ' あいている行に受信日時と取得したデータを書き込み
         excSheet.Cells(iRow, 1) = myMsg.ReceivedTime
         excSheet.Cells(iRow, 2) = strOrderNumber
         excSheet.Cells(iRow, 3) = strCustomerName
         excSheet.Cells(iRow, 4) = strTelephone
         excBook.Save
         excBook.Close
     End If
End Sub
' 本文からデータを取得する関数
Private Function GetText(strName As String, strBody As String) As String
     Dim ls As Long
     Dim le As Long
     ls = InStr(strBody, strName) ' 指定されたフィールド名を検索
     If ls > 0 Then
         ls = ls + Len(strName) ' フィールド名の次の文字から
         le = InStr(ls, strBody, vbCrLf) ' 改行コードまでを取得
         GetText = Trim(Mid(strBody, ls, le - ls)) ' 前後の空白を削除
     Else
         GetText = ""
     End If
End Function

マクロの登録方法やメニューへの追加について