受信者のドメインに応じた署名を追加するマクロ

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


いつも勉強させていただいてます。
ありがとうございます。

新規メールの作成時、メールの返信時において、
  署名をメールの宛先のドメインに合わせて変更することは可能でしょうか。
ぜひご教示いただければ幸いです。
よろしくお願いいたします。

操作環境
Windows 7
  Outlook 2013


以下のマクロは特定のドメインへの署名をドメイン名で作成しておき、受信者のドメインに応じた署名を追加するというものです。
例えば、example.com への返信に使用したい署名はあらかじめ “example.com” という名前で署名を作成しておく必要があります。

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

Public Sub ChangeSignatureByRecipients()
     Dim curItem As MailItem
     Dim strSigFolder As String
     Dim objFSO As Object ' FileSystemObject
     Dim objRec As Recipient
     Dim strRecDomain As String
     ' 表示中のアイテムを取得
     Set curItem = ActiveInspector.CurrentItem
     curItem.Display
     ' 署名が保存されているフォルダーを取得
     strSigFolder = Environ("APPDATA") & "\Microsoft\Signatures\"
     Set objFSO = CreateObject("Scripting.FileSystemObject")
     For Each objRec In curItem.Recipients
         ' 受信者のドメインを取得
         strRecDomain = objRec.Address
         strRecDomain = Mid(strRecDomain, InStr(strRecDomain, "@") + 1)
         ' ドメイン名の署名が存在した場合に署名を挿入
         If objFSO.FileExists(strSigFolder & strRecDomain & ".txt") Then
             Dim stmFile As Object ' TextStream
             ' 署名ファイルを開く
             Set stmFile = objFSO.OpenTextFile(strSigFolder & strRecDomain & ".txt", 1, False, -1)
             Dim docBody As Object ' Document
             Dim strText As String
             Set docBody = curItem.GetInspector.WordEditor
             ' 本文の先頭に署名を追加
             docBody.Parent.Selection.MoveDown
             docBody.Parent.Selection.TypeText stmFile.ReadAll()
             docBody.Parent.Selection.MoveUp 5, 99
             stmFile.Close
             ' 署名を挿入したらループを終了
             Exit For
         End If
     Next
End Sub

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

広告

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

12/5 に Outlook 2016 および Outlook 2013 の累積的な修正プログラムがリリースされました。
以下は各製品のそれぞれの KB へのリンクです。

Office 2016

Outlook 2016 の修正

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

関する不具合修正が行われています。

Office 2013

Outlook 2013 の修正

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

Outlook で画面の表示が乱れる現象が発生する場合の対処方法

 

Outlook を長時間 (環境によっては数時間) 使用し続けると、以下のような現象が発生する場合があります。

  • リボンなどのボタンの表示がされなくなる
  • メールの本文が空白になったり、黒く表示される
  • ナビゲーション ウィンドウのフォルダーが表示されなくなる
  • UI が四角だけで表示される

多くの場合、この現象は画面描画のためのメモリ確保が行えずに発生します。
この記事では、メモリ不足による画面描画を解消するためのいくつかの方法をご紹介します。

OST や PST から不要なアイテムを削除、移動し、使用していない PST をプロファイルから削除する

多くの場合、Outlook では OST や PST というメールを保存するためのファイルを開いています。
これらのファイルは Outlook の起動中には常に開かれた状態となっており、メールの読み書きに伴ってランダムにアクセスされます。
環境によっては一つの OST/PST のサイズが数ギガとなり、さらには複数の PST を同時に開くというようなこともあるでしょう。
そして、現在開いているフォルダーやメールのデータだけでなく、バックグラウンドで処理される動作などによりファイルのデータがメモリ上にキャッシュされ、メモリが大量に使用される動作となります。

したがって、メモリの使用量を抑えるには、普段使用している OST や PST のアイテムの量を減らし、使用していない PST はプロファイルから削除してしまうというものが考えられます。
パフォーマンス上の指標とはなりますが、以下のマイクロソフト技術情報では一つのフォルダーには 10 万アイテム、一つの PST には 500 フォルダーまでが正常な動作範囲というものがあります。

2768656 Outlook performance issues when there are too many items or folders in a Cached mode .ost or .pst file folder

一つのプロファイルあたりどのくらい PST を使えるのかという情報がちょっと見当たらないのですが、結局のところ PST の数というより、すべての PST のサイズを合計してどの程度になるのかという観点で考えたほうが良いかもしれません。

ハードウェア グラフィック アクセラレータを有効にする

Office 2013 以降の Office 製品では、DirectX によるハードウエア グラフィック アクセラレータを使用して画面描画が行われています。
これにより高速な画面描画ができるようになったのですが、一部のアクセラレータで正常な動作が行われない場合があり、[ハードウェア グラフィック アクセラレータを無効にする] をオンにしてアクセラレータを無効にするという方法が問題の対処として実施されている場合があります。
しかし、アクセラレータを無効にすると、画面描画をソフトウェアで実行するため、メモリの使用量が若干増えるようです。

Office 2013 のリリースから 4 年経過し、Office 自体やビデオドライバーの改善により問題が解消されている可能性もありますので、以前何らかの理由で [ハードウェア グラフィック アクセラレータを無効にする] をオンにしていた場合、最新の Office の修正プログラムやグラフィック カードのデバイス ドライバーを適用してアクセラレータを有効にすることで、メモリ消費を抑え、かつ高速に画面描画ができるようになるかもしれません。

高解像度のディスプレイでは DPI を 200% 以上に設定する

最近では高解像度のディスプレイを持つノート PC が普及していますが、このような環境では画面上に表示される情報量が増え、それに伴ってメモリの消費量が増える結果となります。
一例では、1600 x 1200 ピクセルのディスプレイで全画面表示した場合のメモリ消費量が 8 メガバイトあるのに対し、3840 x 2160 ピクセルのディスプレイで全画面表示した場合には 4 倍の 32 メガバイトになったというものがあります。
そのため、高解像度のディスプレイでは DPI を 200% 以上とし、画面に表示される情報量を減らすことでメモリの消費量を抑えることができます。
なお、同様の理由でマルチモニターでの使用や、ウィンドウを多数開くような使用もメモリ消費を増やす原因となりますので、このような使用方法も避けたほうがよいでしょう。

タッチでメッセージのスクロールを行わないようにする

最近のノート PC ではタッチスクリーンが当たり前のようになり、メッセージのスクロールもタッチ操作で行うことができます。
しかし、タッチ操作でスクロールを行うと、メモリの消費が多いという情報があります。
そのため、スクロールはマウスやキーボードで行ったほうが良いようです。

不要なアドインを無効化または削除する

プレインストールで Office がインストールされているような場合、同時にサードパーティ製の Outlook のアドインがインストールされていることがあります。
これらの中には便利なものもあるのですが、最初からインストールされているだけで使ったこともないというようなものもあるでしょう。
不要なアドインを無効化または削除すれば、Outlook のメモリ使用量も抑えることができ、アドインに起因するパフォーマンスの問題なども改善されるかもしれません。

なお、マイクロソフトの Outlook のアドインには以下のようなものがありますが、使用していなければこれらも無効化してかまわないでしょう。

  • Microsoft Exchange Add-in (サーバーが Microsoft Exchange や Outlook.com でなければ不要)
  • Skype Meeting Add-in for Microsoft Office 201X (Skype for Business を使用していなければ不要
  • Microsoft IME Outlook アドイン (連絡先アイテムの姓名フリガナを IME に自動登録しないなら不要)
  • Microsoft SharePoint Server Colleague Import Add-in (SharePoint の連絡先などと同期していないなら不要)
  • OneNote Notes about Outlook Items (メールを OneNote にコピーするような操作を日常的に行っていないなら不要)
  • Microsoft VBA for Outlook AddIn (Outlook のマクロを使用していないなら不要)
  • Outlook Social Connector 2016 (メールの下部に表示される人物情報ウィンドウを使っていないなら不要)

Office 2016/2013 を最新の状態に更新する

Office の共通コンポーネントや Outlook がメールの表示に使用する Word の修正には画面描画やメモリの使用に関する改善が含まれている場合があります。
したがって、Outlook だけでなく、Word や Office の最新の修正プログラムを適用することが現象改善につながるといえます。

さらに、Windows が 64 ビット版で、32 ビットの Outlook 2016 のクリック実行版を使用している場合のみの話ですが、更新チャネルを月次チャネルとして最新の状態 (Version 1709 以降) に更新すると、Outlook 2016 が使用できるメモリの量が 2 ギガバイトから 4 ギガバイトに倍増します。
これは、Windows の Large Address Aware という機能に Outlook 2016 が対応したためです。
通常、Office 2016 をインストールすると、Windows が 64 ビット版であっても、Office アプリケーションは 32 ビット版がインストールされます。
この場合、PC に 2 ギガバイトよりも多いメモリが搭載されていたとしても、32 ビット版のアプリケーションが使用できるメモリの量は最大で 2 ギガバイトに制限されます。
これは、32 ビットの環境では Windows が使用するメモリとして 2 ギガバイトが予約されていることに起因します。
しかし、Windows が 64 ビット版である場合、32 ビット環境で予約されていたメモリ空間をユーザー アプリケーションに開放する Large Address Aware というオプションがあり、Version 1709 以降の Outlook 2016 ではこれが有効となっているので 4 ギガバイトまで使用できるようになったのです。

なお、最新の状態にしても、[ファイル]-[Office アカウント] の 右側の Office ロゴの下のバージョンが 1709 以上にならない場合は、以下のマイクロソフト技術情報の [Download] をクリックして修正プログラムを実行し、更新チャネルを月次チャネルとしてください。

延期チャネルから Office 365 製品ファミリ用の現在のチャネルに切り替える方法

Office 2016 を 64 ビット版に入れ替える

前述の通り、通常は Windows が 64 ビット版であっても Office は 32 ビット版がインストールされます。
これは、アドインやマクロなどが 64 ビットに対応していない状況を考慮したものと思われます。
しかし、マクロやアドインに問題がなければ 64 ビット版にすることで、PC の搭載メモリを十分に活用した処理ができるようになります。
なお、Outlook だけを 64 ビットにするということはできないため、Office 全体をアンインストールし、64 ビット版を再インストールする必要があります。

 

参考情報:

Office 365 ProPlus 更新プログラム チャネルの概要
32-bit Outlook interface elements unexpectedly render in black, white, or blank
Large Address Aware in Outlook 2016

表示中のフォルダーのビューを変更するマクロ

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


いつも参考にさせて頂いております。
ところで定義されたビューをユーザ設定したタブに登録したいと考えております。
VBAでビューを呼び出すことが出来るのでしょうか。
以前にビューをインポートするマクロがあり、それを参考に作成してみましたが、ビューの呼び出しがうまくいきません。
アドバイスを御願いします。


現在表示しているフォルダーのビューを変更したい場合、ActiveExplorer.CurrentView にそのビューの名前を設定します。
例えば、”未読メール” という名前のビューを定義しており、そのビューに変更したい場合は以下のようなマクロで実現できますので、このマクロをリボンのカスタマイズでリボンに追加してください。

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

Public Sub SetViewUnread()
     ActiveExplorer.CurrentView = "未読メール"
End Sub

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

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

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


始めまして。
会社の指定で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

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