メール送信時に社外アドレスを本文の最後に追記するマクロ

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


始めまして。
会社の指定でOutlook2013の利用を始めました。
社外への送信時には、本文の最後にセパレータとして
–@sep
を記載し、改行後に登録したキーワードを記載することになっています。

そこで、以下マクロを教えていただけると非常に助かります。
・キーワードを送信先メールアドレスとし
・宛先に社外メールアドレスがある場合、宛先から社外メールアドレスのみを抽出
・–@sepを本文の最後(署名のあと)に追記
・社外メールアドレスを追記(1メールアドレスごとに改行)
・社内にあたるドメインはグループ会社も含まれるので、複数をマクロ本文内で設定したい。
   @xxx.co.jp,@yyy.co.jp
   など除外ドメインを指定したい。

お手数をおかけいたしますがよろしくお願いします。


メールの送信時に何らかの処理をするには Application_ItemSend イベントを使用します。
このイベントの Item 引数が送信されるメールになりますが、このオブジェクトの Recipients プロパティにより受信者の情報が取得できますので、受信者の Address プロパティからドメイン部分を取得し、あらかじめ定義していたドメインと比較して社内稼働は判断します。
マクロは以下のようになります。
社内ドメインは arrMyDomains = Array("ドメイン1", "ドメイン2") というように Array 関数の引数として @ を含むドメイン名で定義します。
以下のようなマクロで実現できます。
なお、このマクロは BCC で指定された受信者も記録するため、BCC に入れた社外アドレスも本文に記録されてしまいます。
もし、BCC の受信者は社外アドレスでも記録しないということであれば If bExt ThenIf bExt And oneRec.Type <> olBCC Then としてください。

' ここをトリプルクリックでマクロ全体を選択できます。
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
     Const SEP_TOKEN = "-@sep"
     Dim arrMyDomains As Variant
     Dim strExtAddr As String
     Dim oneRec As Recipient
     Dim strDomain As String
     Dim bExt As Boolean
     Dim i As Integer
     ' 社内ドメインを指定
     arrMyDomains = Array("@example1.com", "@example2.com")
     ' 社外アドレス リストを初期化
     strExtAddr = ""
     ' 受信者ごとに繰り返し
     For Each oneRec In Item.Recipients
         ' メールアドレスのドメインを取得
         strDomain = Mid(oneRec.Address, InStr(oneRec.Address, "@"))
         ' 社外アドレス フラグ設定
         bExt = True
         For i = LBound(arrMyDomains) To UBound(arrMyDomains)
             If arrMyDomains(i) = strDomain Then
                 ' 社内アドレスなら社外アドレス フラグ解除
                 bExt = False
             End If
         Next
         ' 社外アドレス フラグが設定されていたら社外アドレス リストに追加
         If bExt Then
             strExtAddr = strExtAddr & oneRec.Address & vbCrLf
         End If
     Next
     ' 社外アドレスが空ではなかったら追記
     If strExtAddr <> "" Then
         If Item.BodyFormat = olFormatPlain Then
             ' テキスト形式なら Body に追記
             Item.Body = Item.Body & vbCrLf & SEP_TOKEN & vbCrLf & strExtAddr
         Else
             ' HTML 形式なら HTMLBody に追記
             Item.HTMLBody = Item.HTMLBody & SEP_TOKEN & "<br>" & _
                 Replace(strExtAddr, vbCrLf, "<br>")
         End If
     End If
End Sub

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

広告

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

11/7 に Outlook 2016 および Outlook 2013 の累積的な修正プログラムがリリースされました。
セキュリティ修正ではない通常の累積プログラムは半年ぶりになりますね。
以下は各製品のそれぞれの KB へのリンクです。

Office 2016

Outlook 2016 の修正

2017 年 11 月 7日で、更新プログラム Outlook 2016 (KB4011240)
10 件の不具合修正が行われています。

Office 2016 共通モジュールの修正

2017 年 11 月 7日で、更新プログラム Office 2016 (KB4011138)
1 件の Outlook に関する不具合修正が行われています。

Office 2013

Outlook 2013 の修正

2017 年 11 月 7日は、Outlook 2013 (KB4011252) の更新します。
4 件の不具合修正が行われています。

Outlook 2013 の修正

2017 年 11 月 7日は、Office 2013 (KB4011229) の更新します。
Outlook に関する不具合修正と機能追加が 1 件ずつ行われています。

受信メールの差出人を連絡先フォルダーのサブフォルダーも含めて検索し、表示名を置き換えるマクロ

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


Windows10、Outlook2016環境です。

受信したメール(受信時・すでに受信済の任意フォルダーにあるメール)の差出人を、アドレス帳にある表示名に置き換えて表示したく、いろいろ試してみたのですがうまくいかずお願いします。

おそらく、連絡先フォルダーをいくつかに仕分けていることが原因だと思われます。

連絡先フォルダーのディレクトリは以下のようになっています

連絡先フォルダー/
 ├ ***@**.****
 ├ ***@**.****
 ├ 連絡先フォルダーA/
 │ ├ ***@**.****
 │ ├ ***@**.****
 ├ 連絡先フォルダーB/
 │ ├ ***@**.****
 │ ├ ***@**.****
 └ 連絡先フォルダーC/
   ├ ***@**.****
   ├ ***@**.****

・受信時、連絡先フォルダーにアドレスが見つからなければ、A、B、C・・・から探し置き換え、なければそのまま表示する

・すでに受信してしまっているメールに対しても同様の処理を行う(手動で可)

同じ差出人でも件名によって振り分けルールを実行しているので、今回のVBA処理で
振り分けを行うことはありません。
  (できれば素晴らしいですが、今回はそこまで求めません)

簡単なことなのかと思うのですが、お願いできると大変助かります。


特定のフォルダーの下のサブフォルダーも検索するという場合、「再帰」という手法を使用します。
連絡先をマクロで活用するという記事のマクロをサブフォルダーに対応させるたマクロは以下のようになります。

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

' メール受信時に発生するイベント
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
     Dim i As Integer
     Dim c As Integer
     Dim colID As Variant
     If InStr(EntryIDCollection, ",") = 0 Then
         RewriteSender EntryIDCollection
     Else
         colID = Split(EntryIDCollection, ",")
         For i = LBound(colID) To UBound(colID)
             RewriteSender colID(i)
         Next
     End If
End Sub
'
' 差出人の名前を置き換えるサブプロシージャ
Private Sub RewriteSender(ByVal strEntryID As String)
     'On Error Resume Next
     Dim objMail 'As MailItem
     Dim objContact As ContactItem
     Dim strSenderAddress As String
     '
     Set objMail = Application.Session.GetItemFromID(strEntryID)
     If objMail.MessageClass = "IPM.Note" Then
         strSenderAddress = objMail.SenderEmailAddress
         Set objContact = FindContactByAddressIncludeSub(strSenderAddress)
         If Not objContact Is Nothing Then
             objMail.SentOnBehalfOfName = objContact.FileAs
             objMail.Save
         End If
     End If
End Sub
'
' 受信トレイの差出人の名前を置き換えるサブプロシージャ
Public Sub RewriteSenderInInbox()
     'On Error Resume Next
     Dim objMail 'As MailItem
     '
     For Each objMail In Application.Session.GetDefaultFolder(olFolderInbox).Items
         RewriteSender objMail.EntryID
     Next
End Sub
'
' アドレスから連絡先フォルダーの配下をすべて検索する関数
Private Function FindContactByAddressIncludeSub(strAddress As String) As ContactItem
     Dim fldContacts As Folder
     '
     Set fldContacts = Application.Session.GetDefaultFolder(olFolderContacts)
     Set FindContactByAddressIncludeSub = FindContactRecursive(fldContacts, strAddress)
End Function
'
' アドレス検索を再帰的に実行する関数
Private Function FindContactRecursive(fldContacts As Folder, strAddress As String) As ContactItem
     On Error Resume Next
     Dim objContact As ContactItem
     Dim fldSub As Folder
     Set objContact = fldContacts.Items.Find("[Email1Address] = '" & strAddress _
         & "' or [Email2Address] = '" & strAddress _
         & "' or [Email3Address] = '" & strAddress & "'")
     '
     If objContact Is Nothing Then
         ' 見つからなければサブフォルダーの検索
         For Each fldSub In fldContacts.Folders
             ' 再帰的に検索
             Set objContact = FindContactRecursive(fldSub, strAddress)
             If Not objContact Is Nothing Then
                 ' 見つかったらループ終了
                 Exit For
             End If
         Next
     End If
     '
     If objContact Is Nothing Then
         Set FindContactRecursive = Nothing
     Else
         Set FindContactRecursive = objContact
     End If
End Function

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

メールの送信時に任意のインターネット ヘッダーを追加するマクロ

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


いつもマクロを参考にさせていただいています。
ありがとうございます。
  利用環境は、windows7 outlook2013で、送信時にメールの宛先や本文内容をチェックする
  マクロを使用しています。

作成したマクロを社内のユーザに配布をして使用してもらう予定なのですが、今後のことも考えて
  ユーザが使用しているバージョンの確認をヘッダ情報で行えないかと考えています。

希望としては、X-Mailer等の情報を変更できれば良いのですがヘッダに何かしら特定の文字列を
追加できればかまいません。

よろしくお願いします。


Outlook でインターネット ヘッダーを追加するには、アイテムの PropertyAccessorSetProperty メソッドを使用します。
このメソッドの SchemaName としてインターネット ヘッダーの名前空間を意味する "http://schemas.microsoft.com/mapi/string/{00020386-0000-0000-C000-000000000046}/" の後に任意のヘッダー名をつけたものを指定し、Value に値を設定すると、送信される MIME 形式のメールのヘッダーに追加されます。
例えば、送信時に x-addinversion: 1.0 というような文字列を追加するマクロのサンプルは以下のようになります。

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

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
     Const ADDIN_VERSION_FIELD = "x-addinversion"
     Const ADDIN_VERSION_VALUE = "1.0"
     Const PS_INTERNET_HEADERS = "http://schemas.microsoft.com/mapi/string/{00020386-0000-0000-C000-000000000046}/"
     '
     Item.PropertyAccessor.SetProperty PS_INTERNET_HEADERS & ADDIN_VERSION_FIELD, ADDIN_VERSION_VALUE
End Sub

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

Outlook 起動時に受信後 14 日が経過しているメールを受信トレイから移動するマクロ

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


いつもお大変世話になっております。

下記の運用を考えておりますが、マクロで対応することは可能でしょうか。
ご検討いただければ幸いです。

■ やりたいこと
受信トレイに保存されているメールアイテムのうち下記の要件に合致
しているメールのみを特定のフォルダへ移動させたい
<要件>
 ・ 受信後、14日が経過している
 ・ 件名に特定の文字列が入っている

■ 利用環境
OSバージョン:Windows7 SP1 & Windows10 RD2
Outlookバージョン:Outlook2016
サーバ:Exchange Online

↑のご依頼させていただいておりますマクロですが、
Application_Startup プロシージャなどを利用して
Outlook起動時にできないかと考えております。


まず、指定された日数経過しているかという点については、DateDiff で確認するという方法もあるのですが、今回は基準となる日付をあらかじめ DateAdd により算出し、それよりも前に受信したメールを移動するという実装にしてみました。
また、件名に特定の文字列が入っているかどうかは Instr 関数で確認できます。
移動先のフォルダーは受信トレイの下の Archive というフォルダーとしていますが、受信トレイと同じレベルのフォルダーに移動したければ、fldInbox.Folders(ARCHIVE_FOLDER)fldInbox.Parent.Folders(ARCHIVE_FOLDER) としてください。
マクロは以下のようになります。

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

Private Sub Application_Startup()
     On Error Resume Next
     ' 移動する経過日数
     Const EXPIRE_DAYS = 14
     ' 移動先のフォルダー名
     Const ARCHIVE_FOLDER = "Archive"
     ' 件名に含む文字列
     Const ARCHIVE_WORD = "test"
     Dim fldInbox As Folder
     Dim fldArchive As Folder
     Dim dtExpire As Date
     Dim i As Integer
     ' 受信トレイを取得
     Set fldInbox = Session.GetDefaultFolder(olFolderInbox)
     ' 移動先フォルダーの取得
     Set fldArchive = fldInbox.Folders(ARCHIVE_FOLDER)
     ' 基準となる日を算出
     dtExpire = DateAdd("d", -EXPIRE_DAYS + 1, Now)
     dtExpire = FormatDateTime(dtExpire, vbShortDate)
     ' 受信トレイのすべてのアイテムについて確認
     For i = fldInbox.Items.Count To 1 Step -1
         With fldInbox.Items(i)
             ' 条件確認
             If InStr(.Subject, ARCHIVE_WORD) > 0 _
               And .ReceivedTime < dtExpire Then
                 .Move fldArchive
             End If
         End With
     Next
End Sub

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

Outlook 2016/2013/2010 のセキュリティ修正プログラム 2017 年 10 月分がリリース

10/10 に Office 2016, 2013 および 2010 のセキュリティ修正プログラムがリリースされました。以下は各製品のそれぞれの KB へのリンクです。

Office 2016

Outlook 2016 のセキュリティ修正

2016 の Outlook のセキュリティ更新プログラムの説明: 2017 年 10 月 10日
2 件のセキュリティ修正と 11 件のセキュリティ以外の修正が行われています。

Word 2016 の修正

2017 年 10 月 3日を Word 2016 (KB4011140) の更新します。
2 件の Outlook 2016 に関する修正が行われています。

Office 2013

Outlook 2013 のセキュリティ修正

Outlook 2013 のセキュリティ更新プログラムの説明: 2017 年 10 月 10日
2 件のセキュリティ修正と 6 件のセキュリティ以外の修正が行われています。

Word 2013 の修正

2017 年 10 月 3日は、Word 2013 (KB4011150) の更新します。
1 件の Outlook 2016 に関する修正が行われています。

Office 2010

Outlook 2010 のセキュリティ修正

Outlook 2010 用のセキュリティ更新プログラムの説明: 2017 年 10 月 10日
1 件のセキュリティ修正が行われています。

受信したメールから取得したキーワードにより Excel を検索し、情報を追記して転送するマクロ

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


コメント失礼します。

windows7 outlook2010です。

やりたいことは、特定のメールから受信し、自動で編集して、再送したいです。今考えているのは受信後自動で各項目ごとにエクセルに転記、転記されたデータをvlookupで別データから参照し値を抽出、その抽出したデータを元のメール文章に追加して送信できればと思っています。

特定のメールアドレスから顧客番号が記載されて送られてきますが、顧客名と住所をいちいち調べなければなりません。現状は顧客名と住所を調べて、元のメール文に追記して再送しています。

それを自動化できればと考えています。

メール文 (例

受信日時 〇〇〇〇

顧客コード 〇〇〇〇〇〇〇〇

内容 〇〇〇〇〇〇〇〇

下記のコードでエクセルに本文を転記することができました。

<コード略>

これだとマクロを実行しないとエクセルに転記されません。

受信毎で自動でエクセルに転記したいです。どこにコードを足せばよいですか?

このあと、エクセルの関数で項目ごとに各セルに振り分けし、(A1:受信日時 B1:顧客コード C1:内容)顧客コードからvlookupで顧客名と住所を抽出まではできましたが、そこから自動でメールを作り、送ることは可能でしょうか?


まず、メールを受信したら自動でマクロを実行したいという場合、Application_NewMailEx を使用します。
Excel に転記するマクロを自動で実行したいとのことですが、転記した後 Excel 側で処理をし、そのうえでメール作成となるとちょっとややこしいことになります。
Outlook で自動処理をしたいのであればすべてを Outlook で実装したほうが効率的でしょう。
Outlook でも本文からデータを取得したり、Excel のシートを検索するという処理を記述することは可能です。
受信したメールから顧客コードを取り出し、Excel を検索して対応する名前と住所を本文に追記して転送するというマクロは以下のようになります。

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

' メール受信時に発生するイベント
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
     Const WORKFLOW_SENDER = "sample@example.com" ' 特定のメールアドレス
     Dim objMail As Object
     Set objMail = Application.Session.GetItemFromID(EntryIDCollection)
     '
     If objMail.MessageClass = "IPM.Note" Then
         If objMail.Sender.Address = WORKFLOW_SENDER Then
             AddNameAndAddressThenSend objMail
         End If
     End If
End Sub
' Excel から顧客情報を取得して送信するプロシージャ
Public Sub AddNameAndAddressThenSend(ByVal objMail As MailItem)
     Const EXCEL_FILE = "C:\sample\sample.xlsx" ' 顧客情報の Excel ファイル
     Const CUSTOMER_SHEET = 1 ' 顧客コードが格納されているシート番号
     Const COL_CODE = 1 ' 顧客コードが格納されている列番号
     Const COL_NAME = 2 ' 顧客名が格納されている列番号
     Const COL_ADDR = 3 ' 住所が格納されている列番号
     Const ROW_START = 2 ' 顧客情報を格納している最初の行
     Dim iPtrCode As Integer
     Dim strCode As String
     Dim objBook 'As Excel.Workbook
     Dim objSheet 'As Excel.Worksheet
     Dim r As Integer
     ' 本文から顧客コードを取得
     iPtrCode = InStr(objMail.Body, "顧客コード")
     If iPtrCode = 0 Then Exit Sub ' 顧客コードが見つからなければ終了
     iPtrCode = iPtrCode + 5
     strCode = Mid(objMail.Body, iPtrCode)
     ' 顧客コードに続く文字列を改行コードまで取得
     strCode = Left(strCode, InStr(strCode, vbCrLf) - 1)
     ' 前後の空白を削除
     strCode = Trim(strCode)
     ' Excel ファイルを開く
     Set objBook = GetObject(EXCEL_FILE)
     Set objSheet = objBook.Sheets(CUSTOMER_SHEET)
     ' 顧客コードをシートから検索
     r = ROW_START
     With objSheet
         While .Cells(r, COL_CODE) <> strCode And .Cells(r, COL_CODE) <> ""
             r = r + 1
         Wend
         '
         If .Cells(r, COL_CODE) = strCode Then ' 顧客コードが見つかったら
             Dim fwdMail As MailItem
             ' 再送メールを作成
             Set fwdMail = CreateItem(olMailItem)
             ' メールの内容を再送メールに転記
             fwdMail.Subject = objMail.Subject
             fwdMail.To = objMail.To
             fwdMail.CC = objMail.CC
             ' 本文に顧客名と住所を追加
             fwdMail.Body = objMail.Body & _
                 "顧客名 " & .Cells(r, COL_NAME) & vbCrLf & _
                 "住所 " & .Cells(r, COL_ADDR) & vbCrLf
             ' メール送信
             fwdMail.Send
         End If
     End With
     objBook.Close
End Sub

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