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

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

Office 2016

Outlook 2016 の修正

Outlook 2016 用のセキュリティ更新プログラムについて: 2020 年10月13日
2 件のセキュリティ修正と 4 件のセキュリティ以外の修正が行われています。

Office 2013

Outlook 2013 の修正

Outlook 2013 用のセキュリティ更新プログラムについて: 2020 年10月13日
2 件のセキュリティ修正が行われています。

Office 2010

Outlook 2010 の修正

Outlook 2010 用のセキュリティ更新プログラムについて: 2020 年10月13日
2 件のセキュリティ修正が行われています。

受信したメールをもとに予定表アイテムを作成するマクロ Ver 2

受信したメールをもとに予定表アイテムを作成するマクロのコメントにて以下のご要望をいただきました。


この度はお世話になります。

私の会社のスケジュール通知の日時の部分が、
「日時:2020年08月26日 17時00分 ~ 2020年08月26日 17時30分」
との書式で送られてきており、
記載のあるマクロで試行錯誤しながらやってはみたのですが、うまく取り込みできません。

※「日時 : 2020/08/26 17:00 – 17:30」と書式を修正すれば記載のあるマクロでは取り込めます。

また、終日イベントの場合は、
「日時:2020年08月26日 ~ 2020年08月26日 【終日】」
との書式で送られてきます。

どうか対応できるコードを教えていただけませんでしょうか?


/ や : の代わりに「年月日」や「時分」を使う場合には、時刻を取得するループの InStr で検索する文字列にそれらを追加します。
また、終了日も指定されている場合を考慮し、終了時刻に日付が含まれていない場合だけ開始日時から日付を取得するようにマクロを変更しました。

' ここをトリプルクリックでマクロ全体を選択できます。
' アイテムを受信するイベント
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
     Dim objItem
     Set objItem = Session.GetItemFromID(EntryIDCollection)
     ' メッセージアイテムのみ処理
     If objItem.MessageClass = "IPM.Note" Then
         SaveAppointmentFromMessage objItem
     End If
End Sub
' メッセージから予定を作成する
Private Sub SaveAppointmentFromMessage(ByVal objMail As MailItem)
     Dim strBody As String
     Dim strSubject As String
     Dim strLocation As String
     Dim strDate As String
     Dim strStart As String
     Dim strEnd As String
     Dim i As Long
     Dim objAppt As AppointmentItem
     ' スケジュール管理ソフト以外からのメールは処理しない
     If Not objMail.Subject Like "スケジュール登録のお知らせ*" Then
         Exit Sub
     End If
     ' 本文を取得
     strBody = objMail.Body
     ' 本文から件名や場所などを取得
     strSubject = GetField(strBody, "件名 : ")
     strLocation = GetField(strBody, "場所 : ")
     strDate = GetField(strBody, "日時 : ")
     If strDate <> "" Then
         ' 開始日時を取得
         i = 1
         While InStr("0123456789/:年月日時分 ", Mid(strDate, i, 1)) > 0 And _
           i <= Len(strDate)
             i = i + 1
         Wend
         strStart = Left(strDate, i - 1)
         ' 日時文字列以外の文字をスキップ
         While InStr("0123456789/:年月日時分 ", Mid(strDate, i, 1)) = 0 And _
           i <= Len(strDate)
             i = i + 1
         Wend
         ' 終了日時を取得
         strEnd = Mid(strDate, i)
         i = 1
         While InStr("0123456789/:年月日時分 ", Mid(strEnd, i, 1)) > 0 And _
           i <= Len(strEnd)
             i = i + 1
         Wend
         strEnd = Left(strEnd, i - 1)
         ' 終了が時刻のみの場合の処理
         If CDate(strEnd) < #1/1/1900# Then
             strEnd = FormatDateTime(CDate(strStart), vbShortDate) & " " & strEnd
         End If
         ' 終日判定
         If InStr(strDate, "終日") > 0 Then
             strEnd = DateAdd("d", 1, CDate(strEnd))
         End If
     Else
         Exit Sub
     End If
     ' 取得した情報で予定アイテムを作成
     Set objAppt = Application.CreateItem(olAppointmentItem)
     objAppt.Subject = strSubject
     objAppt.Location = strLocation
     objAppt.Start = strStart
     objAppt.End = strEnd
     objAppt.Body = strBody
     objAppt.Save
End Sub
' 本文から特定の情報を取得する関数
Private Function GetField(strBody As String, strName As String)
     Dim i As Long
     Dim strValue As String
     i = InStr(strBody, strName)
     If i > 0 Then
         strValue = Mid(strBody, i + Len(strName))
         strValue = Left(strValue, InStr(strValue, vbCrLf) - 1)
         GetField = Trim(strValue)
     Else
         GetField = ""
     End If
End Function

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

メールの受信者と差出人に外部のユーザーが含まれているかどうか分類するマクロ

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


有用なサイトの公開・運営、ありがとうございます。
以下、新しいスクリプト公開の要望をお送りします。

仕分け または 高度な検索において
①所属する組織内(所属する@*****.jp内)でのみやりとりしているメッセージと
②①以外のメッセージを
分類したいです。

既存の仕分けでは「*****.jp以外のドメインを含まない」というルールを作れない為
VBAにて実現するしかないかと思いましたがいかがでしょうか。

Outlook2016です。よろしくお願いします。


差出人のアドレスは MailItem オブジェクトの SenderEmailAddress、受信者のアドレスは Recipient オブジェクトの Address で取得できるので、これらのアドレスに組織内のドメインが含まれているかでチェックは可能です。
ただ、Exchange 環境だと組織内のアドレスが SMTP アドレスではなく EX アドレスとなるので、ExchangeUser オブジェクトの PrimarySmtpAddress により SMTP アドレスを取得する必要があります。
もし、Exchange 環境でないなら下記のマクロの黄色でマークしたコードは不要になります。

マクロとしては現在表示中のフォルダーのすべてのメールの分類を行う CheckInternalCurrentFolder と、フォルダーで選択したメールの分類を行う CheckInternalselected を作りました。
また、これらのマクロから呼び出される CheckInternalOrNot はルールのスクリプトとして呼び出すことが可能ですので、受信メールに対して自動的に分類したい場合はルールで設定してください。

' ここをトリプルクリックでマクロ全体を選択できます。
' 社内ドメインの指定
Const INTERNAL_DOMAIN = "example.com"
' 社内メールに設定する分類項目
Const INTERNAL_CATEGORY = "社内"
' 社外メールに設定する分類項目
Const EXTERNAL_CATEGORY = "社外"
' 現在表示中のフォルダーのメールについてチェックするマクロ
Public Sub CheckInternalCurrentFolder()
     On Error Resume Next
     Dim objItem As Object
     Dim objMsg As MailItem
     For Each objItem In ActiveExplorer.CurrentFolder.Items
         Set objMsg = objItem
         CheckInternalOrNot objMsg
     Next
End Sub
' 現在表示中のフォルダーで選択しているメールについてチェックするマクロ
Public Sub CheckInternalSelected()
     On Error Resume Next
     Dim objItem As Object
     Dim objMsg As MailItem
     For Each objItem In ActiveExplorer.Selection
         Set objMsg = objItem
         CheckInternalOrNot objMsg
     Next
End Sub
' 一つのメールについて社内かどうか判定するマクロ
Public Sub CheckInternalOrNot(ByRef objMsg As MailItem)
     Dim bInternal As Boolean
     Dim strSenderAddr As String
     Dim exchUser As ExchangeUser
     Dim exchDL As ExchangeDistributionList
     Dim objRec As Recipient
     Dim strRecAddr As String
     ' 社内フラグをオン
     bInternal = True
     ' 差出人のアドレスを取得
     strSenderAddr = objMsg.SenderEmailAddress
     If objMsg.SenderEmailType = "EX" Then
         ' 差出人のアドレス種別が Exchange なら ExchangeUser から取得
         Set exchUser = objMsg.Sender.GetExchangeUser
         strSenderAddr = exchUser.PrimarySmtpAddress
     End If

     ' 社内ドメインでなければ社内フラグをオフ
     If Not strSenderAddr Like "*@" & INTERNAL_DOMAIN Then
         bInternal = False
     End If
     ' すべての受信者をチェック
     For Each objRec In objMsg.Recipients
         ' 受信者のアドレス種別ごとにアドレスを取得
         Select Case objRec.AddressEntry.AddressEntryUserType
             Case olSmtpAddressEntry

                 strRecAddr = objRec.Address
             Case olExchangeUserAddressEntry, olExchangeRemoteUserAddressEntry
                 Set exchUser = objRec.AddressEntry.GetExchangeUser
                 strRecAddr = exchUser.PrimarySmtpAddress
             Case olExchangeDistributionListAddressEntry
                 Set exchDL = objRec.AddressEntry.GetExchangeDistributionList
                 strRecAddr = exchUser.PrimarySmtpAddress
         End Select

         ' 社内ドメインでなければ社内フラグをオフ
         If Not strRecAddr Like "*" & INTERNAL_DOMAIN Then
             bInternal = False
         End If
     Next
     If bInternal Then
         ' 社内フラグがオンなら社内の分類項目設定
         objMsg.Categories = INTERNAL_CATEGORY
     Else
         ' 社内フラグがオフなら社外の分類項目設定
         objMsg.Categories = EXTERNAL_CATEGORY
     End If
     objMsg.Save
End Sub

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

ルールのアクションで差出人ごとのメール件数を Excel ファイルで集計するマクロ

特定のドメインの差出人からのメールを受信した際に、その情報をドメイン毎の Excel シートに書き出すマクロのコメントにて以下のご要望をいただきました。


Exchange 環境なので、別記事を参考にNewMailEx イベント起動から、自動仕分けのルールのアクションへ変更し活用中です。
その後、以下の機能をExcel出力に追加したいと考えましたが、実力不足で上手くいきません。
どのようにすればよいかご教示いただけたら幸いです。

利用の前提としては、自動仕分けのルールのアクションから受信期間指定で実行する方法で考えています。
つまり、受信毎でなく実行毎の集計(Excel出力)で考えています。

1) メールアドレス毎、メールの受信回数を記録したい。
2) 受信回数と合わせ、html形式メール、テキスト形式メール、1)の内訳回数を記録したい。
3) 外部アドレスだけでなく、社内アドレスでも集計したい。
  →Exchange 環境なので、LegacyExchangeDN準拠(?)なのか本マクロでは集計対象になりません。
  当初は、外部アドレス対象としており問題なかったのですが、2)の機能を社内アドレスでも
  集計したく、どうすればよいかご教示いただければ幸いです。
  社内アドレスも表記では、エイリアス部分にはemailアドレスが存在します。  
  例)
 日本太郎 / NIHON,TARO


メールの形式は BodyFormat プロパティで判定可能です。

また、Exchange 環境で社内ユーザーの SMTP アドレスも取得するには、送信者を表す Sender プロパティ (AddressEntry オブジェクト) の GetExchangeUser メソッドにより ExchangeUser オブジェクトを取得します。
そして ExchangeUser オブジェクトの PrimarySmtpAddress プロパティで SMTP アドレスを取得できます。

マクロは以下のようになります。

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

' ルールでスクリプトとして呼び出すマクロ
Public Sub SaveReportBySenderAddress(ByRef objMail As MailItem)
     On Error Resume Next
     ' Excel ファイルのファイル名を指定
     Const EXCEL_FILE = "c:\temp\SenderReport.xlsx"
     '
     Dim strSenderAddress As String
     Dim objBook
     Dim objSheet
     Dim r As Integer
     ' Excel ファイルを開く
     Set objBook = GetObject(EXCEL_FILE)
     objBook.Windows(1).Activate
     Set objSheet = objBook.Sheets(1)
     ' 1 行目はタイトルとして使用し、2 行目からデータ
     r = 2
     ' 送信者のアドレスを取得
     strSenderAddress = objMail.SenderEmailAddress
     ' アドレスが LegacyExchangeDN の場合は組織内のユーザー
     If Left(LCase(strSenderAddress), 3) = "/o=" Then
         Dim exUser As ExchangeUser
         ' ExchangeUser オブジェクトを取得
         Set exUser = objMail.Sender.GetExchangeUser()
         ' SMTP アドレスを取得
         strSenderAddress = exUser.PrimarySmtpAddress
     End If
     ' 同じアドレスまたはデータがない行まで移動
     While objSheet.Cells(r, 1) <> "" _
         And objSheet.Cells(r, 1) <> strSenderAddress
         r = r + 1
     Wend
     ' シートにメールの情報を追記
     With objSheet
         ' シートにない新規のエントリーの場合は集計値をリセット
         If .Cells(r, 1) = "" Then
             .Cells(r, 1) = strSenderAddress
             .Cells(r, 4) = 0
             .Cells(r, 5) = 0
             .Cells(r, 6) = 0
         End If
         .Cells(r, 2) = objMail.SenderName
         .Cells(r, 3) = objMail.ReceivedTime
         .Cells(r, 4) = .Cells(r, 4) + 1
         If objMail.BodyFormat <> olFormatPlain Then
             .Cells(r, 5) = .Cells(r, 5) + 1
         Else
             .Cells(r, 6) = .Cells(r, 6) + 1
         End If
     End With
     ' Excel ファイルを閉じる
     objBook.Close True
End Sub

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

メールの受信時に本文のキーワードの後に指定されたサーバー上のフォルダーを開くマクロ

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


Windows10、MS365を使用しています。
定型フォームのメール受信をトリガに、本文中のキーワードと同名のフォルダ(サーバ上)を開くことができないか調べています。
メールは定型のため、本文中のキーワードの位置=特定文字の後ろに続くと文字として、指定できます。
このような処理はできるものでしょうか。見当もつかず困っております。


メールの受信をトリガーにしてマクロを実行するには Application オブジェクトの  NewMailEx イベントを使用します。
本文中のキーワードに続く文字列の取得については、このブログでも何度か登場している定型処理です。
フォルダーを開くには WshShell オブジェクトの Run メソッドを使用します。
このメソッドはコマンドを実行するためのものですが、フォルダー名のみを指定するとエクスプローラーでフォルダーが開かれるのです。
以下のようなマクロで実現できます。

' ここをトリプルクリックでマクロ全体を選択できます。
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
     Dim objItem As Object
     ' 受信したアイテムを取得
     Set objItem = Session.GetItemFromID(EntryIDCollection)
     ' アイテムがメールなら処理を開始
     If TypeName(objItem) = "MailItem" Then
         Dim objMail As MailItem
         Set objMail = objItem
         OpenServerPath objMail
     End If
End Sub
' 本文中のキーワードをもとにサーバーのフォルダーを開くサブ
Private Sub OpenServerPath(ByRef objMail As MailItem)
     ' フォルダー名を指定するキーワード
     Const PATH_KEY = "フォルダー:"
     ' サーバー名
     Const FILE_SERVER = "\\server"
     ' 処理するメールの条件があれば指定
     ' 以下はメールの件名に特定の文字列を含む場合のみ実行する例
     ' If Not (objMail.Subject Like "*文字列*") Then Exit Sub
     '
     If InStr(objMail.Body, PATH_KEY) > 0 Then
         Dim strFolder As String
         Dim wshShell As Object
         strFolder = GetText(PATH_KEY, objMail.Body)
         If strFolder <> "" Then
             Set wshShell = CreateObject("WScript.Shell")
             wshShell.Run FILE_SERVER & "\" & strFolder
         End If
     End If
End Sub
' 本文からデータを取得する関数
Private Function GetText(strName As String, strBody As String) As String
     Dim ls As Long
     Dim le As Long
     ls = InStr(strBody, strName) ' 指定されたフィールド名を検索
     If ls > 0 Then
         ls = ls + Len(strName) ' フィールド名の次の文字から
         le = InStr(ls, strBody, vbCrLf) ' 改行コードまでを取得
         GetText = Trim(Mid(strBody, ls, le - ls)) ' 前後の空白を削除
     Else
         GetText = ""
     End If
End Function

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

Outlook 2016 の累積的な修正プログラム 2020 年 9 月分がリリース

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

Office 2016

Outlook 2016 の修正

September 1, 2020, update for Outlook 2016 (KB4484511)

4 件の修正が行われています。

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

September 1, 2020, update for Office 2016 (KB4484395)

1 件の Outlook に関連する修正が行われています。

Word 2016 のセキュリティ修正

Word 2016 のセキュリティ更新プログラムについて: 2020 年 9 月 9 日

1 件の Outlook に関連する通常の修正が行われています。

Windows 10 上の Outlook のデスクトップ通知が表示されない場合のチェックポイント

Outlook にはメールが着信した際に、デスクトップの右下に通知を表示する機能があります。
Windows 10 上では Windows のアクション センターの機能を使用してこの通知を行うのですが、通知にかかわる設定がいくつかあり、そのどれか一つでも無効になっていると通知が表示されないということになります。

デスクトップ通知が表示されなくなった場合のチェックポイントは以下の通りです。

  • Outlook の [デスクトップ通知を表示]
  • 新着メールの配信先
  • Windows 10 の [アプリやその他の送信者からの通知を取得]
  • Windows 10 の [送信元ごとの通知の受信設定]
  • Windows 10 の [集中モード]
  • スタートメニューへの登録

以下、それぞれの詳細について説明します。

Outlook の [デスクトップ通知を表示]

まず、Outlook の [ファイル]-[オプション]-[メール] の [メッセージ受信] グループの下にある [デスクトップ通知を表示する] がオンになっているかを確認します。
既定ではオンのはずですが、何らかの理由でオフにしてしまうということがあるかもしれません。

新着メールの配信先

デスクトップ通知では自分のメールボックスの受信トレイに配信されたメールのみ通知されます。
そのため、ルールで振り分けを行っている場合や、Exchange 環境で共有メールボックスを追加しているような場合に、それらに配信されたメールについては通知されません。
ルールでフォルダーに振り分けていてもデスクトップ通知を表示したい場合は、ルールのアクションで [デスクトップ通知を表示する] も追加してください。

Windows 10 の [アプリやその他の送信者からの通知を取得]

Windows 10 の [設定] の [システム]-[通知とアクション] には [アプリやその他の送信者からの通知を取得] という設定があります。
これをオンにしないと、Outlook を含むすべてのアプリからの通知がアクション センターに表示されなくなります。

Windows 10 の [送信元ごとの通知の受信設定]

上記と同じ [通知とアクション] の中に、[送信元ごとの通知の受信設定] があります。
画面が小さいとその下にアプリの一覧があることがわかりにくいのですが、スクロールしていくとアプリごとに通知を表示するかしないかの選択ができるようになっています。
ここで、Outlook をオンにしなければ、Outlook の通知がされません。

Windows 10 の [集中モード]

Windows 10 の [設定] の [システム]-[集中モード] では [重要な通知のみ] や [アラームのみ] が選択されていると、Outlook のデスクトップ通知は表示されません。
デフォルトでは [オフ] ですが、何かの拍子に [重要な通知のみ] などになっているかもしれませんので、確認してみてください。

スタート メニューへの登録

Windows 8 以降の仕様として、スタート メニューに登録されていないアプリケーションについては通知がされないというものがあります。
そのため、何らかの理由でスタート メニューの既定の場所に Outlook が登録されていない場合、Outlook のデスクトップ通知は表示されなくなります。
また、この場合は上記の [送信元ごとの通知の受信設定] の下に Outlook が表示されません。
[送信元ごとの通知の受信設定] に Outlook が表示されない場合は、以下のフォルダーに Outlook のショートカットが存在するか確認してみてください。

  Outlook 2013 の場合: C:\ProgramData\Microsoft\Windows\Start Menu\Programs\Microsoft Office 2013
   Outlook 2016 以降の場合: C:\ProgramData\Microsoft\Windows\Start Menu\Programs

もしショートカットが存在しないのであれば、修復セットアップを実行してください。
なお、グループポリシーでメニュー設定をコントロールしていたり、Citrix 環境で使用しているような場合には、ショートカットを作ることができないことがあります。
このような場合は、残念ながらあきらめるしかないということになります。

参考リンク:

デスクトップの通知はありません (トースト通知) Outlook の起動] メニューのショートカットが存在しない場合

Outlook Email Toast Notification Does Not Pop Up in Seamless Published Application

キャッシュ モードのオフラインの期間を取得するスクリプト

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


はじめまして。outlook vba 初心者です。
下記の取得方法をご教授いただければありがたいです。
(outlook2013)
「ファイル」>「アカウント設定」>「アカウント設定(A)」>
「Mictosoft exchange」を選択して「変更」をクリックで表示される
「アカウントの変更」画面の「オフライン設定」の「Exchange キャッシュモードを使う」にチェックが入力されているかどうかと「オフラインにしておくメール:」の期間を取得したいのです。
GetNamespace(“MAPI”)のExchangeConnectionModeでは状態により数値が変化しています。
恐れ入りますが、ヒントだけでもいただければありがたいです。
宜しくお願いいたします


キャッシュ モードの [オフラインにしておくメール] の設定は MAPI プロファイルに格納されています。
具体的な場所についての説明はややこしいので、スクリプトを作成しました。

' ここをトリプルクリックでスクリプト全体を選択できます。
Const LOG_FILE = "C:\temp\cache_sync_window.txt" ' ログを出力するファイル名
Const HKEY_CURRENT_USER = &H80000001
Const MAPI_PROFILE_KEY = "Software\Microsoft\Office\15.0\Outlook\Profiles"
Const OUTLOOK_KEY = "Software\Microsoft\Office\15.0\Outlook"
' Outlook 2016 以降は以下を使用
' Const MAPI_PROFILE_KEY = "Software\Microsoft\Office\16.0\Outlook\Profiles"
' Const OUTLOOK_KEY = "Software\Microsoft\Office\16.0\Outlook"
Const MAPI_SERVICES_KEY = "9207f3e0a3b11019908b08002b2a56c2"
Const PR_STORE_PROVIDERS = "01023d00"
Const PR_EMSMDB_SECTION_UID = "01023d15"
Const SYNC_WINDOW_SETTING_MONTHS = "00036649"
Const SYNC_WINDOW_SETTING_DAYS = "0003665a"
Const PR_PROFILE_DISPLAY_NAME = "001f3001"
Dim stdRegProv
Dim strDefaultProfile
Dim strProfileKey
Dim arrStoreUIDs
Dim strServicesKey
Dim objFS
Dim stmText
Dim iCount
Dim i,j
Dim strServiceKey
Dim strSectionKey
Dim strSectionKeys
Dim strDisplayName
Dim iSyncMonths
Dim iSyncDays
Dim arrData
Dim arrSync
'
Set stdRegProv = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
stdRegProv.GetStringValue HKEY_CURRENT_USER, OUTLOOK_KEY, "DefaultProfile", strDefaultProfile
strProfileKey = MAPI_PROFILE_KEY & "\" & strDefaultProfile & "\"
strServicesKey = strProfileKey & MAPI_SERVICES_KEY
stdRegProv.GetBinaryValue HKEY_CURRENT_USER, strServicesKey, PR_STORE_PROVIDERS, arrStoreUIDs
'
Set objFS = CreateObject("Scripting.FileSystemObject")
Set stmText = objFS.CreateTextFile(LOG_FILE,True)
'
stmText.WriteLine "プロファイル: " & strDefaultProfile
strSectionKeys = ""
iCount = (UBound(arrStoreUIDs)+1)/16
For i=0 To iCount-1
     strServiceKey = ""
     For j=0 To 15
         strServiceKey = strServiceKey & Right("0" & Hex(arrStoreUIDs(i*16+j)), 2)
     Next
     stdRegProv.GetBinaryValue HKEY_CURRENT_USER, strProfileKey & strServiceKey, PR_EMSMDB_SECTION_UID, arrData
     If Not IsNull(arrData) Then
         strSectionKey = ""
         For j=0 To 15
             strSectionKey = strSectionKey & Right("0" & Hex(arrData(j)), 2)
         Next
         '
         If Instr(strSectionKeys, strSectionKey) = 0 Then
             ' 表示名取得
             stdRegProv.GetBinaryValue HKEY_CURRENT_USER, strProfileKey & strSectionKey, PR_PROFILE_DISPLAY_NAME, arrData
             If Not IsNull(arrData) Then
                 strDisplayName = BinToUnicode(arrData)
             End If
             ' 月単位の同期期間を取得
             stdRegProv.GetBinaryValue HKEY_CURRENT_USER, strProfileKey & strSectionKey, SYNC_WINDOW_SETTING_MONTHS, arrSync
             If Not IsNull(arrSync) Then
                 iSyncMonths = arrSync(0)
             Else
                 iSyncMonths = 0
             End If
             ' 月単位の同期期間が設定されていたらログ出力
             If iSyncMonths > 0 Then
                 stmText.WriteLine vbTab & strDisplayName & " の キャッシュ期間: " & iSyncMonths & "カ月"
             End If
             ' 日単位の同期期間を取得
             stdRegProv.GetBinaryValue HKEY_CURRENT_USER, strProfileKey & strSectionKey, SYNC_WINDOW_SETTING_DAYS, arrSync
             If Not IsNull(arrSync) Then
                 iSyncDays = arrSync(0)
             Else
                 iSyncDays = 0
             End If
             ' 日単位の同期期間が設定されていたらログ出力
             If iSyncDays > 0 Then
                 stmText.WriteLine vbTab & strDisplayName & " の キャッシュ期間: " & iSyncDays & "日"
             End If
             '
             strSectionKeys = strSectionKeys & strSectionKey
         End If
     End If
Next
stmText.Close
'
Set stdRegProv = Nothing
Set stmText = Nothing
Set objFS = Nothing
'
Function BinToUnicode( arrData )
     Dim strUnicode
     Dim i
     strUnicode = ""
     For i = 0 To UBound(arrData) Step 2
         strUnicode = strUnicode & ChrW( arrData(i) + arrData(i+1) * &h100 )
     Next
     BinToUnicode = Replace( strUnicode, Chr(0), "" )
End Function

添付ファイルをパスワード付きの ZIP ファイルに圧縮し、そのパスワードを別のメールで送信するマクロ

最初にお詫びしなければならないのですが、この記事のタイトルは釣りです。すみません。

タイトルにあるようなマクロは技術的には可能なのですが、私のポリシーとして作成しません。
理由は以下の 3 つです。

  • 無意味である
  • セキュリティの低下につながる
  • 受信者側の生産性が低下する

上記の理由について詳細に説明します。

無意味である

添付ファイルを暗号化付きの ZIP ファイルにして送信する理由としては、以下のようなものがあげられると考えられます。

  • メールの経路上での情報漏洩を防ぐ
  • 誤送信してしまった際の情報漏洩を防ぐ

確かに、添付ファイルを暗号化付きの ZIP ファイルとして送信し、パスワードは別途電話や FAX などで送信するということなのであれば、意味があると思われます。
しかし、マクロなどで暗号化処理を自動化し、さらに同じ宛先にメールでパスワードを送信してしまった場合、メールの経路上でも誤送信の送信先でもパスワードが入手出来てしまいます。
パスワードが入手できるなら、ZIP ファイルも開けてしまうため、情報漏洩を防ぐことはできません。
そのため、パスワードの送信までを自動的に行うようなマクロは無意味であると言わざるを得ないのです。

セキュリティの低下につながる

パスワード付きの ZIP ファイルは、メールの経路上では開くことができません。
これは、メールサーバー上でのウイルススキャンなどが行えないということを意味します。
また、最近では機密情報や個人情報の漏洩を防ぐために添付ファイルをスキャンするというようなサービスもありますが、このようなサービスも使えなくなります。
つまり、パスワード付きの ZIP ファイルによる添付が当たり前になると、ウイルスの侵入も情報漏洩も防げなくなる可能性があるということです。

受信者側の生産性が低下する

送信側で自動的にパスワード付きの ZIP ファイルとする場合、ほとんど手間はかかりません。
しかし、受信側では ZIP ファイルのパスワードを別のメールから探さなければいけません。
パスワードのメールが元のメールと同じスレッドになっていれば見つけやすいのですが、パスワードのメールの件名に [パスワード] のような文字列が追加されてしまっていたり、インターネット ヘッダーに References などが適切に設定されていなかった場合、受信側でスレッドが分かれてしまいます。
そのため、受信者が大量にメールを受信しているような場合は、パスワードを見つけるという処理のために数分かかるという可能性もあるのです。
また、Outlook ではメールの添付ファイルの内容も検索対象となるのですが、ZIP ファイルに含まれている添付ファイルはインデックスが生成されず、検索対象となりません。
このようなことにより、受信者側の生産性の低下をもたらします。

なお、これらの理由は私の個人的な見解ではなく、セキュリティの専門家などからも指摘されていることです。
実際、インターネット上で「添付ファイル PPAP」で検索すると、このようなやり方を批判するブログなどが数多く見つかります。

代替案

上記のような理由があっても、「そのまま送信するのは不安」ということがあるのかもしれません。
その場合、クラウド添付をお勧めします。
クラウド添付とは添付ファイルをメールではなく OneDrive のようなクラウド ストレージに保存し、そのリンクを添付ファイルとして送信するものです。
OneDrive の場合、アクセスできるユーザーを制限することが可能となるので、仮にリンクが漏洩してもアクセス権がないユーザーはファイルを開くことはできません。
また、誤ったファイルのリンクを送信していたとしても、アクセス権を取り消せばそれ以降のアクセスは防ぐこともできます。

添付ファイルを付けて全員に返信するマクロ Ver 2

添付ファイルをつけて全員に返信するマクロのコメントにて以下のご要望をいただきました。


このマクロを実行すると、元の受信メールのスレッドに反映がされません。
スレッドに反映することは可能でしょうか?


以前のマクロでは、件名を変更してしまっていたため、スレッドが分かれてしまっていました。
スレッドが分かれないようにするためには、スレッドを保ったまま任意の文字列を件名につけて返信するマクロでも使用した Action オブジェクトにより、転送しつつ件名には RE: を付けるというカスタム アクションを作成します。
そして、このアクションで作成された転送メールに、別途作成した全員返信メールの宛先を追加します。
マクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub ReplyAllWithAttachments()
     Dim objItem As MailItem
     Dim objAction As Action
     Dim objReplyAttach As MailItem
     Dim objReply As MailItem
     Dim recSrc As Recipient
     Dim recDst As Recipient
     '
     If TypeName(ActiveWindow) = "Inspector" Then
         Set objItem = ActiveInspector.CurrentItem
     Else
         Set objItem = ActiveExplorer.Selection(1)
     End If
     ' 件名に RE: をつけて転送するアクションを作成
     Set objAction = objItem.Actions.Add
     objAction.CopyLike = olForward
     objAction.Name = "添付ファイル付き返信"
     objAction.Prefix = "RE"
     objAction.ReplyStyle = olUserPreference
     objAction.ShowOn = olDontShow
     ' 上記アクションの実行により転送メールを作成
     Set objReplyAttach = objAction.Execute
     ' 全員に返信するメールを作成
     Set objReply = objItem.ReplyAll
     ' 転送メールの宛先に返信メールの宛先を指定
     For Each recSrc In objReply.Recipients
         strAddress = recSrc.Address
         If recSrc.AddressEntry.Type = "SMTP" And _
            strAddress <> recSrc.Name Then
             strAddress = """" & recSrc.Name & """ " & _
                          "<" & strAddress & ">"
         End If
         Set recDst = objReplyAttach.Recipients.Add(strAddress)
         recDst.Type = recSrc.Type
         recDst.Resolve
     Next
     objReply.Close olDiscard
     objReplyAttach.Display
End Sub

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