会議室の一覧を取得するマクロ

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


はじめまして。

マクロを使用して、現在登録されている会議室名をすべて取得したいと考えています。

どのような関数を利用して、実現するのがよいのかお知恵を拝借できれば幸いです。


登録されている会議室名というのは、Exchange サーバーの会議室メールボックスとして登録されているアカウントの名前ということでよいでしょうか?
会議室の一覧を取得するというような関数はありませんので、以下のような手順で取得する必要があります。

  1. アドレス帳の一覧からグローバル アドレス一覧を取得する
  2. グローバル アドレス一覧のエントリーから PR_DISPLAY_TYPE_EX の値が DT_ROOM であるエントリーを抽出して取得する

マクロにすると以下のようになります。
取得した会議室名をどのように使うのかがわからなかったので、この関数では会議室名を文字列の配列に格納して返しています。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Function GetRooms() As String()
     On Error Resume Next
     Const PR_DISPLAY_TYPE_EX = "http://schemas.microsoft.com/mapi/proptag/0x39050003"
     Const DT_ROOM = 7
     Dim alGAL As AddressList
     Dim aeUser As AddressEntry
     Dim strRooms As String
     ' Exchange のグローバル アドレス一覧を取得
     For Each alGAL In Session.AddressLists
         If alGAL.AddressListType = olExchangeGlobalAddressList Then
             Exit For
         End If
     Next
     ' グローバル アドレス一覧から会議室メールボックスを検索
     strRooms = ""
     For Each aeUser In alGAL.AddressEntries
         If aeUser.AddressEntryUserType = olExchangeUserAddressEntry Then
             Dim lType As Long
             lType = aeUser.PropertyAccessor.GetProperty(PR_DISPLAY_TYPE_EX)
             ' PR_DISPLAY_TYPE_EX が DT_ROOM なら会議室
             If lType = DT_ROOM Then
                 strRooms = strRooms & aeUser.Name & vbTab
             End If
         End If
     Next
     ' 会議室一覧の文字列を配列に変換
     If Len(strRooms) > 0 Then
         strRooms = Left(strRooms, Len(strRooms) - 1)
         GetRooms = Split(strRooms, vbTab)
     End If
End Function

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

本文の内容から時間を取得してフラグの期限を設定するマクロ

本文の内容からフラグの期限を設定するマクロのコメントにて以下のご要望をいただきました。


このマクロの応用で、時間を本文から取得してフラグを設定するマクロを作りたいのですが、理解が足りず挫折してしまいました。
やりたいことは、
・期限の日付は、メール受信の当日でOK
・「予定終了時間:」の後に続く時間(例:19:00)を取得して、その時間を期限として
 アラームが立ち上がるようなフラグを立てたい。

どう書き換えればよいか、教えて頂けないでしょうか?


以下のようなマクロで実現できます。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub AddFlagWithAlarmByTime()
     Dim objMsg As MailItem
     Dim i As Integer
     Dim strTime As String
     Dim strDate As String
     '
     If Not ActiveInspector Is Nothing Then
         Set objMsg = ActiveInspector.CurrentItem
     ElseIf ActiveExplorer.Selection.Count = 1 Then
         Set objMsg = ActiveExplorer.Selection(1)
     Else
         MsgBox "メッセージを開くか、選択してください。", vbCritical, "フラグ追加"
         Exit Sub
     End If
     '
     i = InStr(objMsg.Body, "予定終了時間:")
     If i > 0 Then
         i = i + 7
         strTime = ""
         While InStr(" 0123456789:", Mid(objMsg.Body, i, 1)) > 0
             strTime = strTime & Mid(objMsg.Body, i, 1)
             i = i + 1
         Wend
         strDate = FormatDateTime(Now, vbShortDate) & " " & strTime
         '
         objMsg.MarkAsTask olMarkToday
         objMsg.FlagRequest = "ご確認ください"
         objMsg.TaskStartDate = Now
         objMsg.TaskDueDate = strDate
         objMsg.ReminderSet = True
         objMsg.ReminderTime = strDate
         objMsg.Save
     End If
End Sub

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

Outlook 2016/2013 でルールによるアプリケーションやマクロの実行ができない

2017 年 5 月以降にリリースされた Outlook 2016 の修正プログラム、または 6 月以降にリリースされた Outlook 2013 の修正プログラムを適用すると、以下のような現象が発生します。

  • アプリケーションやマクロを実行するルールが (エラー) と表示される
  • 新規ルール作成で「アプリケーションを開始する」や「スクリプトを実行する」というアクションが選択肢からなくなる

これは、セキュリティ強化に伴う動作変更です。

ただし、機能が完全に削除されたわけではなく、以下のレジストリ設定を行うことで引き続き「アプリケーションを開始する」や「スクリプトを実行する」というアクションが使用できるようになります。

Outlook 2016 のキー: HKEY_CURRENT_USER\Software\Microsoft\Office\16.0\Outlook\Security\

Outlook 2013 のキー: HKEY_CURRENT_USER\Software\Microsoft\Office\15.0\Outlook\Security\

値の名前: EnableUnsafeClientMailRules

値の種類: REG_DWORD

値のデータ: 1

– 参考リンク

How to control the rule actions to start an application or run a macro in Outlook 2016 and Outlook 2013

Outlook 2013/2010 の定例外の修正プログラムがリリース

6/27 に Outlook 2013 と Outlook 2010、また 6/30 に Outlook 2016 の定例外の修正プログラムがリリースされました。
6 月の Outlook のセキュリティ修正にはいくつか不具合が確認されているのですが、そのうち添付ファイルに関するものについての修正が行われているようです。
以下は各製品の KB へのリンクです。

Outlook 2016 の修正

June 30, 2017, update for Outlook 2016 (KB3213654)
3 件の修正が行われています。

Outlook 2013 の修正

June 27, 2017, update for Outlook 2013 (KB3191849)
3 件の修正が行われています。

Outlook 2010 の修正

July 5, 2017, update for Outlook 2010 (KB4011042)
3 件の修正が行われています。
32 ビット版の修正にクラッシュするという不具合が見つかり、7/5 に再リリースされました。

特定の連絡先から受信者のアドレスのエントリーを検索し、電子メール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 で警告が出ます。
最近出るようになったということなのであれば、単にパターンファイルが最新でないだけではないかとも思いますが、ウイルス スキャン ソフトの状態がどうなっているかをコントロール パネルで確認してみてください。

参考:

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