社外のアドレスを宛先に含む場合のみ BCC を追加するマクロ

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


Outlookで常に特定のメールアドレスを[Bcc:]に入れて送信するマクロを組みたいのですが、できれば加えて宛先が社外のメールのみという指定ができればと思っております。
  全送信メールに対して設定するマクロについては、検索で見つけることができ、設定して試してみたところ問題なく動作しました。
ただ、「社外メールのみ」という部分を検索で指定すると、自分の検索方法が悪いのかもしれないのですが、見つけることができず、こちらでコメントさせて頂いた次第です。当方、マクロなど素人につき、お教えいただけたら幸いです。どうぞ、よろしくお願い致します。

使用環境
Windows10
  office2016


宛先が社外のメールかどうかを判断するには、宛先のアドレスのドメインを確認する必要があります。
メールアドレスは Recipient オブジェクトの Address プロパティで確認できるのですが、Outlook.com に接続しているような場合は Address プロパティでは SMTP アドレスが取得できないこともあります。
そのため、アドレス取得のロジックは Exchange 環境下で組織外のアドレスに送信する際に警告を表示するマクロのものを流用しています。
マクロは以下の通りです。

' ここをトリプルクリックでマクロ全体を選択できます。
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
     Const MY_DOMAIN = "*@example.com" ' 自組織のドメイン名を指定。@ の前に * を付ける
     Const BCC_ADDR = "bcc@example.com" ' BCC として追加するアドレス
     Dim objRec As Recipient
     Dim strSMTPAddr As String
     Dim bExternal As Boolean
     Dim recBcc As Recipient
     ' 組織外の受信者が存在するかどうかの確認
     bExternal = False
     For Each objRec In Item.Recipients
         strSMTPAddr = GetSMTPAddr(objRec)
         If Not strSMTPAddr Like MY_DOMAIN Then
             bExternal = True
             Exit For
         End If
     Next
     ' 組織外の受信者が複数含まれていた場合は BCC を追加
     If bExternal Then
         Set recBcc = Item.Recipients.Add(BCC_ADDR)
         recBcc.Type = olBCC
         recBcc.Resolve
         Item.Save
     End If
End Sub
' SMTP アドレス取得関数
Private Function GetSMTPAddr(objRec As Recipient)
     Const PR_ORIGINAL_DISPLAY_NAME = "http:" & "//schemas.microsoft.com/mapi/proptag/0x3a13001e"
     Const PR_SMTP_ADDRESS = "http:" & "//schemas.microsoft.com/mapi/proptag/0x39fe001e"
     Dim strSMTPAddr As String
     If objRec.AddressEntry.Type = "SMTP" Then
         strSMTPAddr = objRec.Address
     Else ' Exchange 対応
         If objRec.AddressEntry.AddressEntryUserType = olOutlookContactAddressEntry Then
             strSMTPAddr = objRec.AddressEntry.PropertyAccessor.GetProperty(PR_ORIGINAL_DISPLAY_NAME)
         Else
             strSMTPAddr = objRec.AddressEntry.PropertyAccessor.GetProperty(PR_SMTP_ADDRESS)
         End If
     End If
     GetSMTPAddr = strSMTPAddr
End Function

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

広告

2020 年の海の日、山の日および体育の日を移動するスクリプト

6 月 13 日に 2020 年の海の日、山の日および体育の日が東京オリンピックに合わせて移動されるという法律が可決、成立しました。

今後、この法律に基づいて更新された Outlook の祝日ファイルも更新プログラムとして提供されることになると思いますが、すでに延長サポート フェーズに入っている Outlook 2013 や Outlook 2010 には提供されない可能性があります。
また、Outlook 2016 でも、更新プログラムを適用すれば変更されるというわけではなく、いったん祝日を削除して改めて追加するという作業が必要になります。

そのようなわけで、祝日を移動するスクリプトを作ってみました。
スクリプトは以下の通りです。

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

Const olFolderCalendar = 9
Dim olkApp
Dim fldCal
' Outlook の予定表を取得
Set olkApp = CreateObject("Outlook.Application")
Set fldCal = olkApp.Session.GetDefaultFolder(olFolderCalendar)
' 祝日ごとに移動
MoveHoliday fldCal, "海の日", "7/20", "7/23"
MoveHoliday fldCal, "山の日", "8/11", "8/10"
MoveHoliday fldCal, "体育の日", "10/12", "7/24"
' 一つの祝日を移動するプロシージャ
Sub MoveHoliday(fldCal, strName, strStart, strNewStart)
     Dim apptHol
     ' 件名と日付により祝日を検索
     Set apptHol = fldCal.Items.Find("[件名]='" & strName & _
         "' And [開始日]='2020/" & strStart & " 00:00'")
     ' 見つかったら新しい日付に移動
     If Not apptHol Is Nothing Then
         apptHol.Start = CDate("2020/" & strNewStart)
         apptHol.Save
     End If
End Sub

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

6/12 に Outlook 2016、Outlook 2013 および Outlook 2010 のセキュリティ修正プログラムがリリースされました。

以下は各製品のそれぞれの KB へのリンクです。

Office 2016

Outlook 2016 の修正

2016 の Outlook のセキュリティ更新プログラムの説明: 2018 年 6 月 12日
1 件のセキュリティ修正と 12 件のセキュリティ以外の修正が行われています。

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

2018 年 6 月 5日更新プログラム Office 2016 (KB4022156)
1 件の Outlook に関する不具合の修正が行われています。

2018 年 6 月 5日更新プログラム Office 2016 (KB4022159)
1 件の Outlook に関する不具合の修正が行われています。

Office 2013

Outlook 2013 の修正

Outlook 2013 のセキュリティ更新プログラムの説明: 2018 年 6 月 12日
1 件のセキュリティ修正と 5 件のセキュリティ以外の修正が行われています。

Office 2010

Outlook 2010 の修正

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

マクロの署名に必要な証明書

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


いつもお世話になっております。
マクロのセキュリティで証明書付きのマクロのみを有効にする設定でマクロを有効にする場合の証明書について教えていただけないでしょうか。当方ではPC利用環境毎に証明書が発行され認証にも使用されています。また、インストールソフトウェアの変更はポリシー上許可されておらずofficeのSELFCERT.EXEは未導入の状況です。以上のことから発行済みの証明書を使用してマクロを動作させたいと考えているのですが証明書選択画面で選択を押下しても有効な証明書はありませんと表示されます。マクロを動作させるための証明書について形式、証明書の種類、保存フォルダ等の制限についてどなたかご教示いただけないでしょうか。

よろしくお願いいたします。


マクロの署名に必要な証明書としては以下の要件を満たす必要があります。

  • 秘密鍵を保持する
  • 証明書の目的として [コード署名] を含む
  • Windows の証明書ストアに格納されている

上記の要件についてそれぞれ説明します。

秘密鍵を保持する

マクロの署名には公開鍵基盤 (PKI) が使用されており、この方式では以下の 2 つの鍵が必要となります。

秘密鍵: デジタル署名の署名作成と暗号化の解除に使用
公開鍵: デジタル署名の署名の確認と暗号化に使用

このうち、秘密鍵については極めて重要なものであるため、証明書の発行を依頼したユーザーにのみ秘密鍵を含む証明書が発行されます。

証明書の目的として [コード署名] を含む

一口に証明書といっても、その用途は以下の通り様々です。

  • サーバーの証明
  • クライアントの証明
  • S/MIME の署名、暗号化
  • 暗号化ファイル システム
  • コード署名

そして、証明書の目的が限定されている場合、それ以外の目的では証明書として使用することはできません。
マクロの署名を行うには [コード署名] に使用できる証明書が必要となるので、例えばクライアントの認証に使われる [クライアントの証明] の証明書があったとしても、マクロの署名には使用できません。
なお、証明書の目的は証明書の発行のタイミングで設定されるので、すでに発行されている証明書に目的を追加することはできません。

Windows の証明書ストアに格納されている

Outlook は証明書を Windows の証明書ストアから検索します。
そのため、証明書がファイルとして存在していても、それが参照されることはありません。
秘密鍵を保持する証明書がファイルとしてローカルにあるのであれば、それを証明書ストアにインストールする必要があります。
通常は、その証明書ファイルをダブルクリックすると証明書のインポート ウィザードが起動してインポートできます。
なお、この時パスワードが要求されない場合、その証明書には秘密鍵が入っていないと考えられます。

まとめ

証明書をどのような形で発行・取得されているのかが不明ですが、「コード署名証明書」や「コードサイニング証明書」というキーワードで検索すれば、ご使用になられている証明機関でのコード署名証明書の発行手順はわかると思います。

受信したメールの添付ファイルに日付と連番を付けて自動保存するマクロ

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


大変参考にさせていただいております。

初心者なもので、大変恐縮ですが、教えてください。

元の添付ファイルのファイル名:abc

保存したいファイル名:yyyymmdd_01_abc
(年月日_その日の受信の連番(2桁)_添付ファイル名)

としたい場合、どうしたらよろしいでしょうか?

何卒よろしくお願いします。


年月日を追加したい場合は、Format 関数の第 1 パラメータに現在の日時を表す Now 関数を指定し、第 2 パラメータとして “yyyymmdd” という文字列を指定すれば可能です。
問題は「その日の受信の連番」をどうやって管理するかです。
ファイルやレジストリを使って管理する方法もあるのですが、今回は Outlook の StorageItem というオブジェクトを使ってみました。
StorageItem は受信トレイなどの任意のフォルダーに隠しアイテムとして設定などを保存することができるというものです。
マクロは以下のようになります。

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

' 連番を保持する StorageItem オブジェクト
Dim myStgCount As StorageItem
' メール受信時に発生するイベント
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
     On Error Resume Next
     Dim objMsg As MailItem
     '
     Set objMsg = Session.GetItemFromID(EntryIDCollection)
     If Not objMsg Is Nothing Then
         SaveAttachmentsWithDate objMsg
     End If
End Sub
'
' 添付ファイルの保存を行うサブ プロシージャ
Private Sub SaveAttachmentsWithDate(objMsg As MailItem)
     Const SAVE_PATH = "C:\attachments\"
     Dim objAttach As Attachment
     Dim iSerial As Integer
     Dim strDate As String
     Dim strFileName As String
     '
'
' ここで条件指定
'
     ' 日付を文字列に変換
     strDate = Format(Now, "YYYYMMDD_")
     ' 添付ファイルすべてについて処理
     For Each objAttach In objMsg.Attachments
         With objAttach
             ' 日ごとの連番を取得
             iSerial = GetSerialForToday()
             ' ファイル名に日付と連番を追加
             strFileName = SAVE_PATH & strDate & Format(iSerial, "0#_") & .FileName
             ' ファイルを保存
             .SaveAsFile strFileName
         End With
     Next
     Set objMsg = Nothing
     Set objFSO = Nothing
End Sub
'
' 日ごとの連番を取得する関数
Private Function GetSerialForToday()
     Const COUNT_SUBJECT = "GLOBAL_COUNTER"
     Dim fldInbox As Folder
     Dim myStgCount As StorageItem
     Dim strToday As String
     Dim propDate As UserProperty
     Dim propCount As UserProperty
     ' 連番を保持する StorageItem オブジェクトを取得
     If myStgCount Is Nothing Then
         Set fldInbox = Session.GetDefaultFolder(olFolderInbox)
         Set myStgCount = fldInbox.GetStorage(COUNT_SUBJECT, olIdentifyBySubject)
     End If
     ' 今日の日付を取得
     strToday = FormatDateTime(Now, vbShortDate)
     ' 連番を保持している日付を取得
     Set propDate = myStgCount.UserProperties.Find("CountDate")
     If propDate Is Nothing Then
         ' プロパティがなければ新規追加
         Set propDate = myStgCount.UserProperties.Add("CountDate", olText)
         propDate.Value = strToday
     End If
     ' 連番を取得
     Set propCount = myStgCount.UserProperties.Find("Counter")
     If propCount Is Nothing Then
         ' プロパティがなければ新規追加
         Set propCount = myStgCount.UserProperties.Add("Counter", olInteger)
         propCount.Value = 0
     End If
     ' 日付が変わっていたら連番をリセット
     If propDate.Value <> strToday Then
         propDate.Value = strToday
         propCount.Value = 1
     Else
         ' 日付が変わっていなければ連番を追加
         propCount.Value = propCount.Value + 1
     End If
     ' 変更後の連番と日付を保存
     myStgCount.Save
     GetSerialForToday = propCount.Value
End Function

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

表示しているメールの差出人のメールアドレスで検索を実行するマクロ

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


受信したメールを選択し、クイックアクセスツールバーに設置したボタンをクリックし
  すべてのoutlookアイテムから、送信者のメールアドレスで検索表示するマクロを作りたいです。
ご教授お願いします。

OS:Winndows10 Office365


すべての Outlook アイテムの検索を行うには、Explorer オブジェクトの Search メソッドの 2 番目のパラメータで olSearchScopeAllOutlookItems を指定します。
以下のようなマクロを定義し、クイック アクセス ツールバーでこのマクロを呼び出すように設定すれば、ご要望の動作が可能です。

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

Public Sub FindBySender()
     Dim objItem As MailItem
     '
     If TypeName(ActiveWindow) = "Inspector" Then
         Set objItem = ActiveInspector.CurrentItem
     Else
         Set objItem = ActiveExplorer.Selection(1)
     End If
     '
     ActiveExplorer.Search """" & objItem.SenderEmailAddress & """", olSearchScopeAllOutlookItems
End Sub

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

受信したメールを自動的に MSG ファイルとして保存するマクロ

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


お世話になります。

いつも参考にさせていただいています。

受信をトリガーとし、メール自体を.msgファイルとして保存する場合はどのようになるのでしょうか?


メール自体を保存する場合は、MailItem オブジェクトの SaveAs メソッドを使用します。
件名をファイル名にする場合、件名には \ や :、* などファイル名に使用できない文字が含まれる場合があるため、それを別の文字に置き換える必要があります。
以下のマクロでは受信時のイベントで SaveAsMsg というプロシージャを呼び出し、その中で条件判定をするようにしていますが、条件判定のための記述がよくわからないというようであれば、SaveAsMsg だけをマクロとして定義し、自動仕分けのルールのスクリプトとして SaveAsMsg を呼び出すようにすれば、条件判定をルールの設定でできるようになります。

' ここをトリプルクリックでマクロ全体を選択できます。
' メール受信時に発生するイベント
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
     On Error Resume Next
     Dim objItem As Object
     Dim objMsg As MailItem
     ' 受信アイテムを取得
     Set objItem = Session.GetItemFromID(EntryIDCollection)
     ' アイテムがメールだったら保存処理
     If TypeName(objItem) = "MailItem" Then
         Set objMsg = objItem
         SaveAsMsg objMsg
     End If
End Sub
  '
  ' MSG ファイルとして保存するサブ プロシージャ
Public Sub SaveAsMsg(ByRef objMsg As MailItem)
     ' ファイルを保存するフォルダーを指定。最後に \ が必要
     Const SAVE_PATH = "C:\temp\"
     Dim objFSO As Object ' FileSystemObject
     Dim strSubject As String
     Dim strFileBase As String
     Dim strFileName As String
     Dim i As Integer
     Dim ch As String
     Dim c As Integer
     '
     Set objFSO = CreateObject("Scripting.FileSystemObject")
'
' ここで条件指定
' 例えば、test という文字列を件名に含むものだけ保存する場合、
' 「test を件名に含まない場合に Exit Sub」というコードにする
'
'  If Not (objMsg.Subject Like "*test*") Then Exit Sub
'
     ' 件名をファイル名にする
     strSubject = objMsg.Subject
     ' 件名の前に受信日時をつける場合は以下を使用
     ' strSubject = objMsg.ReceivedTime & " " & objMsg.Subject
     ' 件名の前に差出人をつける場合は以下を使用
     ' strSubject = objMsg.SenderName & " " & objMsg.Subject
     ' ファイル名に使用できない文字を _ に置き換える
     strFileBase = ""
     For i = 1 To Len(strSubject)
         ch = Mid(strSubject, i, 1)
         If InStr("\/:*?""<>|", ch) > 0 Then
             ch = "_"
         End If
         strFileBase = strFileBase & ch
     Next
     '
     strFileName = SAVE_PATH & strFileBase & ".msg"
     '
     c = 1
     ' 同名のファイルが存在したら
     While objFSO.FileExists(strFileName)
         ' ファイル名に -連番 をつける
         strFileName = SAVE_PATH & strSubject & "-" & c & ".msg"
         c = c + 1
     Wend
     ' MSG ファイルとして保存する
     objMsg.SaveAs strFileName, olMSG
     Set objFSO = Nothing
End Sub

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