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

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


いつもマクロを参考にさせていただいています。
ありがとうございます。
  利用環境は、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

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

送信者が自分以外のメールを受信した際に添付ファイルを自動保存するマクロ

受信したメールの添付ファイルを自動保存するマクロのコメントにて以下のご要望をいただきました。


いつもありがとうございます。
  「受信したメールの添付ファイルを自動保存するマクロ」を使用させていただいています。

追加機能として、自分が送付したメールの添付を自動保存から除外するマクロを教えていただけませんでしょうか。
VBA初心者で、色々試してみましたが、出来ませんでした。
お力をお借りできますと幸いです。(グループアドレス等に送信する場合、自分にもメールが入るので、その際除外できればと考えています。)


まず、メールの送信者のアドレスは、MailItem オブジェクトの Sender.Address プロパティにより取得できます。
(SenderEmailAddress というプロパティもありますが、こちらは Outlook 2013 以降でのみ使用可能です。)
一方、自分自身のアドレスは Session.CurrentUser.Address により取得できます。
そのため、添付ファイルの保存の前にこの二つのアドレスを比較し、一致していたら保存をキャンセルするという処理を追加することでご要望を実現することができます。

以前のマクロにこの処理を追加したものは以下の通りです。

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

' メール受信時に発生するイベント
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
         SaveAttachments EntryIDCollection
     Else
         colID = Split(EntryIDCollection, ",")
         For i = LBound(colID) To UBound(colID)
             SaveAttachments colID(i)
         Next
     End If
End Sub
'
' 添付ファイルの保存を行うサブ プロシージャ
Private Sub SaveAttachments(ByVal strEntryID As String)
     Const SAVE_PATH = "C:\attachments\"
     Dim objFSO As Object ' FileSystemObject
     Dim objMsg As Object
     Dim objAttach As Attachment
     Dim strFileName As String
     Dim c As Integer: c = 1
     '
     Set objMsg = Application.Session.GetItemFromID(strEntryID)
     '
     If LCase(objMsg.Sender.Address) = LCase(Session.CurrentUser.Address) Then
         Exit Sub
     End If
     Set objFSO = CreateObject("Scripting.FileSystemObject")
     '
     ' ここで条件指定
     '
     For Each objAttach In objMsg.Attachments
         With objAttach
           
             strFileName = SAVE_PATH & objAttach.FileName
            
             While objFSO.FileExists(strFileName)
                 strFileName = SAVE_PATH & Left(.FileName, InStrRev(.FileName, ".") - 1) _
                     & "-" & c & Mid(.FileName, InStrRev(.FileName, "."))
                 c = c + 1
             Wend
            
             .SaveAsFile strFileName
         End With
     Next
     Set objMsg = Nothing
     Set objFSO = Nothing
End Sub

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

受信したメールの本文を 1 行ごとに処理するマクロ

決まった件名のメッセージを受信したら、データを CSV ファイルに保存するマクロのコメントにて以下のご要望をいただきました。


度々申し訳ございません。メールの本文を1行毎に処理するというのは可能でしょうか。

メール本文が何行あるかは定まってなく、
任意の文字列1
任意の文字列2
任意の文字列3

といった内容のメールが来た時、
任意の文字列1がXXで終わってたらXXの前N文字を取得してCSVに書き出し、
無ければ任意の文字列1を全てCSVに書き出すという処理を、
メール本文終わりまで行いたいです。


プログラミングにおいて「行」というのは改行コード (キャラクタ コード 13 および 10 ) で終わる一連の文字列となります。
そのため、本文を Split 関数で改行コードにより分割し、分割された文字列に対して必要な処理を行うことで、1 行ずつの処理ができます。
マクロは以下のようになります。
XX や N は冒頭の Const  で指定してください。

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

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
     Const XX = "XX"
     Const N = 5
     Const CSV_FILE = "c:\temp\report.csv"
     Dim objItem As Object
     Dim arrLine As Variant
     Dim strLine As String
     Dim i As Integer
     '
     Set objItem = Session.GetItemFromID(EntryIDCollection)
     If objItem.MessageClass = "IPM.Note" Then
         ' CSV ファイルを追記モードで開く
         Open CSV_FILE For Append As #1
         ' 本文を改行コードで行に分割
         arrLine = Split(objItem.Body, vbCrLf)
         For i = LBound(arrLine) To UBound(arrLine)
             strLine = arrLine(i)
             ' 行が指定のキーワードで終わるか確認
             If strLine Like "*" & XX Then
                 ' 行が指定のキーワードより前に文字列を含むかチェック
                 If Len(strLine) > Len(XX) Then
                     ' 行末の指定のキーワードを削除
                      strLine = Left(strLine, Len(strLine) - Len(XX))
                     ' 残りが N 以上か確認
                     If Len(strLine) >= N Then
                         ' N 文字だけ抜き出す
                          strLine = Mid(strLine, Len(strLine) - N + 1)
                     End If
                 End If
             End If
             If Len(strLine) > 0 Then
                 ' 取得した行を CSV ファイルに書き出す
                 Print #1, strLine
             End If
         Next
         Close #1
     End If
End Sub

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

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

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

Office 2016

Outlook 2016 のセキュリティ修正

Outlook 2016 セキュリティ更新プログラムについて2017 年 9 月 12 日
1 件のセキュリティ修正と 8 件のセキュリティ以外の修正が行われています。

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

2017 年 9 月 5日で、更新プログラム Office 2016 (KB3191923)
1 件の Outlook 2016 に関する修正が行われています。

2017 年 8 月 22日、更新プログラム Office 2016 (KB4011093)
1 件の Outlook 2016 に関する修正が行われています。

Word 2016 の修正

2017 年 9 月 5日を Word 2016 (KB4011039) の更新します。
1 件の Outlook 2016 に関する修正が行われています。

Office 2013

Outlook 2013 のセキュリティ修正

Outlook 2013 セキュリティ更新プログラムについて2017 年 9 月 12 日
1 件のセキュリティ修正と 1 件のセキュリティ以外の修正が行われています。

Office 2010

Outlook 2010 のセキュリティ修正

Outlook 2010 セキュリティ更新プログラムについて2017 年 9 月 12 日
1 件のセキュリティ修正が行われています。

Office 2007

Outlook 2007 のセキュリティ修正

Outlook 2007 セキュリティ更新プログラムについて2017 年 9 月 12 日
1 件のセキュリティ修正が行われています。