特定の連絡先から受信者のアドレスのエントリーを検索し、電子メール2のアドレスに置き換えて返信するマクロ

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


はじめまして、いつもこのサイトの内容に助けられております。

要望なのですが、メール返信時に特定の連絡先フォルダーを参照して、同じメールアドレスの連絡先の、電子メール2のアドレスに置き換えて返信ウィンドウを開くマクロを作成することは可能でしょうか。

よろしくお願いします。


以下のようなマクロで実現できます。
マクロ中の CONTACT_FOLDER_PATH には検索する連絡先フォルダーのパスを指定します。
例えば、user@example.com というアカウントの “連絡先” フォルダーの下の “取引先” というようなフォルダーの場合、通常は “user@example.com\連絡先\取引先” という文字列を指定します。
なお、場合によっては “個人用 Outlook データ ファイル\連絡先” のような場合もありますので、正確なパスはフォルダー一覧を表示して確認してください。

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

Public Sub ReplyWithSecondAddress()
     Dim curItem As MailItem
     Dim repItem As MailItem
     Dim i As Integer
     Dim oneRecip As Recipient
     Dim newAddress As String
     Dim newRecip As Recipient
     '
     If TypeName(ActiveWindow) = "Inspector" Then
         Set curItem = ActiveInspector.CurrentItem
     Else
         Set curItem = ActiveExplorer.Selection(1)
     End If
     Set repItem = curItem.ReplyAll
     '
     For i = repItem.Recipients.Count To 1 Step -1
         Set oneRecip = repItem.Recipients(i)
         ' 電子メール 2 を検索
         newAddress = FindSecondAddress(oneRecip.AddressEntry)
         ' 電子メール 2 が見つかったら置き換え
         If newAddress <> "" Then
             Set newRecip = repItem.Recipients.Add(newAddress)
             newRecip.Type = oneRecip.Type
             oneRecip.Delete
         End If
     Next
     '
     repItem.Recipients.ResolveAll
     repItem.Display
End Sub
'
' 特定のフォルダーから連絡先を検索し、電子メール 2 のアドレスを返す関数
'
Private Function FindSecondAddress(addrEntry As AddressEntry) As String
     ' 検索する連絡先フォルダーのパスを指定
     Const CONTACT_FOLDER_PATH = "メールアドレス\連絡先\テスト"
     Dim arrPath As Variant
     Dim i As Integer
     Dim fldContact As Folder
     Dim objContact As ContactItem
     Dim newAddress As String
     ' 連絡先フォルダーを検索
     arrPath = Split(CONTACT_FOLDER_PATH, "\")
     Set fldContact = Session.Folders(arrPath(0))
     For i = 1 To UBound(arrPath)
         Set fldContact = fldContact.Folders(arrPath(i))
     Next
     ' 電子メール 1 のアドレスを検索
     Set objContact = fldContact.Items.Find("[Email1Address] = '" & addrEntry.Address & "'")
     If Not objContact Is Nothing Then
         With objContact
             ' 連絡先が見つかったら電子メール 2 のアドレスを確認
             If .Email2Address <> "" Then
                 ' 電子メール 2 が設定されていたら戻り値として設定
                 If InStr(.Email2DisplayName, .Email2Address) > 0 Then
                     newAddress = .Email2DisplayName
                 Else
                     newAddress = .Email2DisplayName & " <" & .Email2Address & ">"
                 End If
             End If
         End With
     Else
         newAddress = ""
     End If
     FindSecondAddress = newAddress
End Function

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

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

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

Office 2016

Outlook 2016 のセキュリティ修正

2016 の Outlook のセキュリティ更新プログラムの説明: 2017 年 6 月 13日

3 件のセキュリティ修正が行われています。

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

2016 の Office のセキュリティ更新プログラムの説明: 2017 年 6 月 13日
1 件の Outlook 2016 に関するセキュリティ関連ではない修正が行われています。
2017 年 6 月 6日、更新プログラム Office 2016 (KB3191933)
1 件の Outlook 2016 に関する修正が行われています。

Office 2013

Outlook 2013 のセキュリティ修正

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

Office 2013 のセキュリティ修正

Office 2013 のセキュリティ更新プログラムの説明: 2017 年 6 月 13日
2 件の Outlook 2013 に関するセキュリティ関連ではない修正が行われています。    

Office 2010

Outlook 2010 の修正

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

Office 2007

Outlook 2007 の修正

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

セキュリティ更新プログラムに関する問題

上記のセキュリティ修正プログラムを適用すると、以下の 2 つの問題が発生します。

Outlookを操作するスクリプトを実行すると「Outlook 内に保存されている電子メール アドレス情報がプログラムによってアクセスされようとしています。」と警告が出る現象について

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


outlook2013(office365proplus)です。
ここでいろいろ参考にさせていただいて、予定表をテキストで取り出すvbsを
使っております。
数か月は問題なく使っていたのですが、最近、下記セキュリティのアラートが出るようになりました。
「Outlook内に保存されている電子メールアドレス情報がプログラムによってアクセスされようとしています。なんたら」
数分ごとに実行するようにスケジューリングしているので、事実上アラートが邪魔で使えない状況です。。
いろいろ調べたのですが、「セキュリティセンターの設定でプログラムによるアクセス」を「不審な動作に関する警告を表示しない」にする、というのしか見つかりません。(私は管理者ではないので、この項目を変更できません)
特定のプログラムを許可するようなオプションも見つかりません。
何か対策は無いでしょうか。
最近突然使えなくなったのは何かマイクロソフトで仕様変更したのでしょうか。。


メールアドレスへのアクセスの警告メッセージは、以下のような条件でスクリプトなどにより Outlook のオブジェクト モデルでメールアドレスが含まれるプロパティを参照した場合に表示されます。

  • ウイルス スキャン ソフトがインストールされていない
  • ウイルス スキャン ソフトのパターンファイルが最新でない
  • ウイルス スキャン ソフトのライセンスが切れている

これらのチェックには Windows の機能が使われており、たとえ実際にはウイルススキャンソフトがインストールされていたとしても、Windows のコントロール パネルの [セキュリティとメンテナンス] で [ウイルス対策] が有効で最新の状態になっていなければ Outlook で警告が出ます。
最近出るようになったということなのであれば、単にパターンファイルが最新でないだけではないかとも思いますが、ウイルス スキャン ソフトの状態がどうなっているかをコントロール パネルで確認してみてください。

参考:

電子メール アドレスの情報にアクセスしようとしているか、自分の代わりに電子メールを送信しようとしているプログラムに関する警告が表示される

msg ファイルとして保存しようとするとメモリ不足でエラーになる原因

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


はじめまして。これほど情報量満載のサイトがある
のを知り感動いたしました。
早速質問させて戴きたく。

Outlook2013上で所定フォルダ上のメールメッセージを
SaveAsメソッドによりディスクにmsg形式で保存する
VBAを作成していますが、メールメッセージがmsg形式
の添付ファイルを持つ場合に保存が失敗し、そこで
メモリエラーでプログラムが途中終了してしまいます。
保存の際、ディスク上に16kBのmsgファイルが出来る
のですがサイズがそこから増えることなく、エラー
「処理を実行するためのメモリが不足しています」が
出て、途中終了するとともに、上記ファイルが自動
削除されます。

【試行実験】
・msg形式での保存では、Unicodeの如何を問わず保存不能
・マニュアルで「ファイル~名前をつけて保存(msg形式)」
でも保存不能
・保存不能のケースで、TXT形式での保存は可能
・添付のmsgファイルが壊れていることはおそらくなく、
ダブルクリックで開いてみることが可能。但しそれを
保存することも同じエラーで不能。
・メールメッセージをexplorer上のD&Dしてmsg形式で
保存することは可能

【相談事項】
所定フォルダ上の複数のメールメッセージを1つずつ
msg形式でプログラムで保存したいので、
・最終的には、対象とするメールメッセージを全て保存したい
・不能なメッセージがあってもそこで途中終了せず、次の対象
の保存に取りかかれるようにせめてしたい

【参考】
添付ファイルのmsgが大きなサイズの場合に失敗するようですが、
以下には必ずしもそうでは無く沢山の相手先が設定されていると
失敗するとの話もあるそうです。もはや私には理解が及びません。
https://www.experts-exchange.com/questions/28536821/Outlook-vba-cannot-save-a-large-Msg-file-to-disk-error-2147024882-There-is-not-enough-free-memory.html
https://social.msdn.microsoft.com/Forums/office/en-US/2836370d-33dd-44fe-b480-26edcf1f6859/does-the-saveas-method-in-microsoftofficeoutlookinterop-have-a-maximum-file-size?forum=outlookdev
何卒よろしくお願いいたします。


msg ファイルがメモリ不足で保存できないという現象が発生する場合、ほとんどは msg ファイルで使用されている OLE 複合ファイルという形式の制限に起因して発生しています。

OLE 複合ファイルとは Windows で一つのファイルに様々な情報をオブジェクトという形で保存する形式のファイルです。
多くのファイル フォーマットは、特定のデータを保存するための形式であり、例えばテキスト形式なら文字列データ、JPG 形式なら画像データなどを保存します。
しかし、OLE 複合ファイルについてはどのようなデータでも保存可能とするため、データをオブジェクトという形で複数保存できるようになっています。
実際、Office 2003 までは Word も Excel も PowerPoint も OLE 複合ファイルの形式でファイルを保存しており、Word ファイルの中に Excel データの一部を埋め込んだり、拡張子を削除してもダブルクリックすると適切なアプリケーションで自動的に開いたりできていました。

Outlook も他の Office 製品と同様に OLE 複合ファイル形式で msg ファイルや oft ファイルを保存しており、メールに含まれる受信者や添付ファイルはそれぞれ個別のオブジェクトとしてファイルに格納されています。
また、メールに別のメールを添付しているという場合、添付されたメールも単一のデータではなく、そのメール自体の受信者や添付ファイルが個別のオブジェクトとして保存されます。
そのため、多数の受信者や添付ファイルを含むメールを保存する場合、一つの OLE 複合ファイル内に大量のオブジェクトが生成されるということになります。
しかし、OLE 複合ファイルでは一つのファイル内で同時に開くことができるオブジェクトの数が制限されており、この制限を超えるような書き込みが行われた場合に「メモリ不足」という意味のエラーが発生するのです。

SaveAs で保存できないアイテムを Explorer にドラッグアンドドロップすると保存ができるようですが、この場合はファイルへの書き込みを行うのは Explorer であり、Explorer が何らかの方法で制限を回避しているものと思われます。
(あるいは単にエラーを無視しているだけかもしれません。)

いずれにせよ、残念ながら、マクロで SaveAs により msg ファイルとして保存する場合にマクロの記述方法やレジストリ設定などでこの制限を回避する方法はありません。
このエラーが発生した場合に処理を中断させたくないということであれば、SaveAs の前に On Error Resume Next を実行し、エラーで中断せずに継続させるようにしてください。

参考リンク:

No MSG For You! – SGriffin’s MAPI Internals

[INFO] MSG 複合ファイルへのメッセージの保存

VBA の実行時エラーを処理する

ビューをファイルにエクスポート・インポートするスクリプト

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


いつも大変お世話になっております。
可能であればマクロ作成をご検討頂きたいのです。
OS:Windows 7 Professional(64bit)
Outlook2013
【ビューの定義をエクスポート(インポート)するマクロ】
【印刷スタイルの定義をエクスポート(インポート)するマクロ】
ビューの定義や印刷スタイルの定義を社内で統一して利用したい。
私が現在設定しているビューを
PC内(Outlook2013)でコピーする事は出来ますが
別PC(Outlook2013)へビューや印刷スタイルの定義を
エクスポート(インポート)する事は出来ないでしょうか?
標準の機能として、これらの定義のエクスポート(インポート)はないようなので
マクロで作成可能であればお願いしたい次第です。
ビューについては
【現在のビューの設定をサブフォルダにコピーするマクロ】や
2014年2月22日 コメントでの要望を受けての
全てのストアのフォルダー階層にアクセス可能な
【現在のビューをすべてのフォルダーに適用するマクロ】
上記の2つのマクロをどうにかすれば可能なのでしょうか?
ご検討の程、よろしくお願い申し上げます。


まず、印刷スタイルの定義ですが、こちらは以下のファイルに保存されています。(ファイルに拡張子はありません)

    c:\users\ユーザー名\AppData\Roaming\Microsoft\Outlook\OutPrnt

このファイルを単にコピーすれば、他の環境に印刷スタイルの定義をコピーすることができます。

次に、ビューの設定ですが、こちらはご指摘のマクロでやっているように、View オブジェクトの XML プロパティの文字列をエクスポート・インポートすれば、他の環境にビューの定義をコピーすることができます。
ただし、自動書式についてはコピーすることはできません。

現在表示しているフォルダーの現在のビュー設定をファイルにエクスポートするスクリプトは以下のようになります。
複数の PC で実行することを想定したため、スクリプトとして実装しました。
この内容をメモ帳などのテキストエディタに貼り付け、拡張子を .vbs として保存し、ダブルクリックして実行してください。

' ここをトリプルクリックでスクリプト全体を選択できます。
Const VIEW_XML = "C:\temp\current.view" ' エクスポート先のファイル名
Dim olkApp
Dim objFSO
Dim curView
Dim stmXml
Dim strXml
Set olkApp = CreateObject("Outlook.Application")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set curView = olkApp.ActiveExplorer.CurrentFolder.CurrentView
strXml = curView.XML
Set stmXml = objFSO.CreateTextFile(VIEW_XML)
' 1 行目はビューの名前と種類
stmXml.WriteLine curView.Name & vbTab & curView.ViewType
stmXml.Write strXml
stmXml.Close

また、上記のスクリプトでエクスポートしたビュー設定を、現在表示しているフォルダーにインポートするスクリプトは以下のようになります。

' ここをトリプルクリックでスクリプト全体を選択できます。
On Error Resume Next
Const VIEW_XML = "C:\temp\current.view" ' インポート先のファイル名
Dim olkApp
Dim objFSO
Dim stmXml
Dim strLine
Dim arrLine
Dim colViews
Dim curView
Set olkApp = CreateObject("Outlook.Application")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set stmXml = objFSO.OpenTextFile(VIEW_XML, 1)
' 1 行目はビューの名前と種類
strLine = stmXml.ReadLine
arrLine = Split(strLine, vbTab)
Set colViews = olkApp.ActiveExplorer.CurrentFolder.Views
Set curView = colViews.Add(arrLine(0), arrLine(1), 0)
If Err.Number = 5 Then ' 同名のビューが存在した場合のエラー処理
    For Each curView In colViews
        ' 同名のビューを検索
        If curView.Name = arrLine(0) Then
            Exit For
        End If
    Next
End If
curView.XML = stmXml.ReadAll
curView.Save
curView.Apply
stmXml.Close

年、月、日の階層構造のフォルダーを作成してアイテムを移動するマクロ

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


お世話になります。今回初めてコメントをさせていただきます。Outlook2010、Outlook2013の環境で、決まった差出人のメールを、受信トレイ配下に階層深くチェックした後に、移動させたいのですが、その時にフォルダが存在しない時は、作成してメールを移動させたいのですが、1回目は階層深くフォルダを作成し、移動することはできるようになったのですが、翌日、同じマクロを実行すると、最階層の下にフォルダをまた、階層深く作成してしまって、どうにかして、最階層だけ作成して、メールを移動するようにしたいのですが、よくわからないのです。ご教授いただけると助かります。
受信トレイから→チェック済→年度→月→日に移動させたいのです。翌日は新しい日のフォルダが月の下に作成されて、メールが移動される。月が変わったら、新しく月と日のフォルダを作成して、日のフォルダにメールが移動される。年度が変わったら、年度、月、日のフォルダが作成され、新しい日のフォルダにメールが移動されるようにしたいのです。マクロVBAを作成した経験がなく、非常に困っております。どなたかご教授いただけると助かります。よろしくお願いいたします。


フォルダーが存在するかどうかを確認し、存在しない場合だけ作成するようにすれば、ご要望の動作は満たせるでしょう。
以下のようなマクロで実現できます。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub MoveByDate()
    Dim objItem As MailItem
    Dim dt As Date
    Dim fldInbox As Folder
    Dim fldChecked As Folder
    Dim fldYear As Folder
    Dim fldMonth As Folder
    Dim fldDay As Folder
    ' 現在開いているか選択しているアイテムを取得
    If TypeName(Application.ActiveWindow) = "Inspector" Then
        Set objItem = ActiveInspector.CurrentItem
    Else
        Set objItem = ActiveExplorer.Selection(1)
    End If
    '
    Set fldInbox = Session.GetDefaultFolder(olFolderInbox)
    Set fldChecked = GetOrCreateFolder(fldInbox, "チェック済み")
    dt = Now ' 今日の日付でフォルダーを作成
    ' フォルダをアイテムの受信日時により作成する場合は下記の記述を使用
    ' dt = objItem.ReceivedTime
    Set fldYear = GetOrCreateFolder(fldChecked, Year(dt))
    Set fldMonth = GetOrCreateFolder(fldYear, Month(dt))
    Set fldDay = GetOrCreateFolder(fldMonth, Day(dt))
    '
    objItem.Move fldDay
End Sub
'
Private Function GetOrCreateFolder(fldParent As Folder, strName As String)
    On Error Resume Next
    Dim fldSub As Folder
    For Each fldSub In fldParent.Folders
        If fldSub.Name = strName Then
            Set GetOrCreateFolder = fldSub
            Exit Function
        End If
    Next
    Set fldSub = fldParent.Folders.Add(strName)
    Set GetOrCreateFolder = fldSub
End Function

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

HTML 形式の本文に文字列を追加する方法

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


いつも参考にさせて戴いております。今回初めて質問致します。
HTML形式で図が含まれているメールに対して
mailItem の reply メソッドを行うと図が保持されますが、本文に何かを追記しようとすると図が失われます。
保持する方法はありますでしょうか。
(Outlook 2010 or 2013, VBA はExcel から起動)
ex) objReply.body = “test” + objReply.body –> 図がなくなる


MailItem オブジェクトの Body プロパティはテキスト形式の本文を参照あるいは設定するためのプロパティです。
そのため、このプロパティに文字列を設定すると、メッセージ形式が自動的にテキスト形式に変換され、HTML の書式や図は失われてしまいます。

HTML 形式のメールの本文は HTMLBody プロパティを使って参照や設定を行います。
ただし、本文の先頭に文字列を追加する際に、以下のようにしてしまうと想定外の動作をする場合があります。

objReply.HTMLBody = "test" & objReply.HTMLBody

HTMLBody プロパティは HTML のタグを含んだ HTML 本文全体を取得するのですが、その先頭には <HEAD> タグで囲まれた CSS の定義などが存在します。
それらの定義の前に文字列を追加してしまうと、適切な処理ができなくなる可能性があるのです。

そのため、HTML 本文の先頭に文字列を追加する場合、本文の開始を意味する BODY タグを検出し、その後ろに文字列を追加する必要があります。
以下は、HTML 本文の先頭に文字列を追加するサブルーチンの例です。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub InsertStringToHTMLBody(objItem As MailItem, strText As String)
    Dim i As Long
    ' body タグの開始を検索
    i = InStr(LCase(objItem.HTMLBody), "<body")
    ' body タグの終了を検索
    i = InStr(i, objItem.HTMLBody, ">")
    ' body タグの終了位置に文字列を挿入
    objItem.HTMLBody = Left(objItem.HTMLBody, i) & strText & Mid(objItem.HTMLBody, i + 1)
    Debug.Print objItem.HTMLBody
End Sub