件名に含まれるキーワードにより送信警告の表示を制御するマクロ


コメントで以下のようなご要望をいただきました。


会社の環境はOutlook2007なのですが、以前ご紹介いただいた、「メールの宛先を送信前に確認するマクロ」をもう少し進化させる事が出来ないかと思案しております。
このマクロでは、外部ドメインが宛先、CCフィールドに入っているとアラートが出るわけですがこれを、
1) メールタイトルに記載されたキーワードを取り込み
2) このキーワードに対応するメールドメインとは異なる外部ドメインが宛先、CCフィールドに入っている場合にアラートが出る
ようにしたいと思います。
例えば、タイトルに、”【***社様】”と入っている場合には、***社に対応するメールドメイン(@***.co.jp)を事前に指定する事で、@***.co.jp以外の社外ドメインが含まれる場合にアラートを出させたいと思います。
当然、タイトルで検索させる社名分のドメインリストを事前に作って、マクロに貼り付ける必要があるのですが、「どうしても誤送信をしては困る宛先」を数社に絞れば実用可能だと思います。
例えば、前作と組み合わせる事で、
1) ドメインリストに記載がある社名に送信する場合で、異なるドメインが宛先に入っている場合には、大きめのアラートを表示させ
2) タイトルに、【***社】のように指定がない場合には、前作のような外部ドメインが宛先に入っているかどうかだけをチェックさせる
と出来ると思うのですが・・・


このご要望について、以下のような実装を考えました。

  1. メールボックス直下の「DomainList」というフォルダにキーワードと送信可能なアドレスを設定しておき、その設定に基づいてチェックを行なう。
  2. 連絡先の分類項目にキーワードを設定しておき、その設定に基づいてチェックを行なう。

マクロ サンプルは記事の最後に紹介しますが、これを使用するために必要な設定について説明します。

A. ドメイン リストの設定

この設定は、ご要望どおり特定のキーワードを含む件名のメッセージについて、指定されたドメインとは異なるドメインが含まれている場合にダイアログを表示するためのものです。
手順としては、まず、メールボックスの直下に DomainList という名前のフォルダを作成します。
次に、キーワードと送信可能なアドレスをそれぞれ件名と本文に記載した投稿アイテムを DomainList フォルダに保存します。例えば、「Microsoft」というキーワードが含まれる件名のメッセージで「@microsoft.co.jp」および「@microsoft.com」以外のドメインで警告を表示する場合は、以下のような投稿アイテムを DomainList に投稿します。


件名: Microsoft
本文:
*@microsoft.co.jp
*@microsoft.com


ドメインの前に * がついていますが、これはメール アドレスをワイルドカードを使ってあらわすようにしたためです。これなら、あるドメインの特定のユーザーのみ警告を表示しないというような設定も可能です。
なお、ドメインが複数ある場合には改行で区切ります。

このようなアイテムをキーワードごとに投稿します。

B. 連絡先の分類項目の設定

私としては、Outlook の連絡先も活用したかったので、送信の際に受信者が連絡先に登録されている場合は、その連絡先の分類項目の文字列が件名に含まれているかどうかをチェックし、含まれている場合は警告しないという機能も加えました。

連絡先のアイテムを開き、[分類]-[すべての分類項目] で任意の文字列を追加します。こうすることで、指定した文字列を件名に含むメッセージの場合、その連絡先への送信は警告ダイアログが表示されないようになります。

なお、上記のチェックは社外のアドレスに対してのみ行なわれます。

以下は、サンプルコードです。

' ここをトリプルクリックでマクロ全体を選択できます。
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    Cancel = CheckRecipients(Item)
End Sub
'
Private Function CheckRecipients(Item As Object) As Boolean
    Const MyDomain = "@example.com" ' 社内扱いするドメインを指定します。
    ' SMTP アドレスを格納する MAPI プロパティの TAG です。URL ではありません。
    Const PR_SMTP_ADDRESS = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
    Dim i As Integer
    Dim j As Integer
    Dim strAddress As String
    Dim strExtAddr As String
    If Item.MessageClass Like "IPM.TaskRequest*" Then
        Set Item = Item.GetAssociatedTask(False)
    End If
    ' Phase 1 - 社外のアドレスのみを抽出
    strExtAddr = ""
    For i = 1 To Item.Recipients.Count
        With Item.Recipients.Item(i)
            strAddress = .Address
            If LCase(strAddress) Like "/o=*" Then
                ' アドレスが Exchange アドレスなら、SMTP アドレスを取得
                strAddress = .PropertyAccessor.GetProperty(PR_SMTP_ADDRESS)
            End If
            If Not strAddress Like "*" & MyDomain Then
                strExtAddr = strExtAddr & strAddress & ";"
            End If
        End With
    Next
    ' 社外アドレスが存在する場合のみの処理
    If strExtAddr <> "" Then
        Dim arrAddress
        Dim arrPattern
        Dim fldDomainList 'As Folder
        Dim itmDomain 'As PostItem
        Dim strPrompt As String
        Dim objContacts 'As Folder
        Dim objContact 'As ContactItem
        ' アドレスが ' でくくられていたら削除
        If strExtAddr Like "'*'" Then
            strExtAddr = Mid(strExtAddr, 2, Len(strExtAddr)-2)
        End If
        ' 社外アドレスを配列に格納
        arrAddress = Split(strExtAddr, ";")
        strExtAddr = ";" & strExtAddr
        ' Phase 2 - ドメイン リストのチェック
    ' DomainList フォルダを取得
        Set fldDomainList = Session.GetDefaultFolder(olFolderInbox).Parent.Folders("DomainList")
        For Each itmDomain In fldDomainList.Items
            ' DomainList のアイテムの件名がメッセージの件名に含まれていた場合
            If InStr(Item.Subject, itmDomain.Subject) > 0 Then
                ' アイテムの本文を改行で分割し、アドレス パターンを取得
                itmDomain.BodyFormat = olFormatPlain
                arrPattern = Split(itmDomain.Body, vbCrLf)
                ' 受信者のアドレスとアドレス パターンの照合
                For i = 0 To UBound(arrAddress) - 1
                    For j = 0 To UBound(arrPattern)
                        ' アドレス パターンと一致するアドレスは社外アドレスから除外
                        If arrAddress(i) Like arrPattern(j) Then
                            strExtAddr = Replace(strExtAddr, ";" & arrAddress(i) & ";", ";")
                            Exit For
                        End If
                    Next
                Next
                ' アドレス パターンに一致しないアドレスが存在した場合
                If strExtAddr <> ";;" Then
                    strPrompt = String(54, "*") & vbLf & "このメッセージの件名には「" & itmDomain.Subject _
                        & "」が含まれていますが、このキーワードでは以下のアドレスは許可されていません。[OK] をクリックすると送信します。" _
                        & Replace(strExtAddr, ";", vbLf) & String(54, "*")
                    If MsgBox(strPrompt, vbOKCancel + vbExclamation) = vbCancel Then
                        CheckRecipients = True ' 送信しない
                    Else
                        CheckRecipients = False ' 送信する
                    End If
                Else
                    CheckRecipients = False ' 送信する
                End If
                ' ドメイン リストが合致したら以降の処理は行なわない
                Exit Function
            End If
        Next
        ' Phase 3 - 受信者ごとの分類項目チェック
        ' 連絡先フォルダを取得
        Set objContacts = Session.GetDefaultFolder(olFolderContacts)
        For i = 0 To UBound(arrAddress) - 1
            ' 受信者のアドレスを連絡先から検索
            Set objContact = objContacts.Items.Find("[Email1Address] = '" & arrAddress(i) _
                & "' or [Email2Address] = '" & arrAddress(i) _
                & "' or [Email3Address] = '" & arrAddress(i) & "'")
            If Not objContact Is Nothing Then
                ' 連絡先アイテムが存在したら、分類項目をチェック
                If objContact.Categories <> "" Then
                    ' 分類項目を配列に格納
                    arrPattern = Split(objContact.Categories, ", ")
                    For j = 0 To UBound(arrPattern)
                        ' 分類項目を件名に含む場合は社外アドレスから除外
                        If InStr(Item.Subject, arrPattern(j)) > 0 Then
                            strExtAddr = Replace(strExtAddr, ";" & arrAddress(i) & ";", ";")
                            Exit For
                        End If
                    Next
                End If
            End If
        Next
        ' 連絡先がない、もしくは分類項目の文字列が件名にないアドレスが存在した場合
        If strExtAddr <> ";;" Then
            strPrompt = "このメッセージには以下の社外アドレスが含まれています。[OK] をクリックすると送信します。" & Replace(strExtAddr, ";", vbLf)
            If MsgBox(strPrompt, vbOKCancel + vbExclamation) = vbCancel Then
                CheckRecipients = True ' 送信しない
                Exit Function
            End If
        End If
    End If
    CheckRecipients = False ' 送信する
End Function

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

広告

件名に含まれるキーワードにより送信警告の表示を制御するマクロ」への3件のフィードバック

  1. いつも参考にしています。Like “/o=*” の意味が勉強不足で理解できず苦慮しています。
    よろしければ解説頂けますと助かります。

    • Like というのは VB でワイルドカードなどを使った文字列比較ができる演算子です。
      xxx Like “/o=*” というのは xxx に含まれる文字列が /o= で始まる場合という意味になりますが、これは電子メールアドレスが /o= で始まる場合は Exchange サーバーが内部的に使用する電子メールアドレスであり、「受信者が Exchange サーバーの組織内にいる」という意味となります。

      Like 演算子の詳細は http://msdn.microsoft.com/ja-jp/library/swf8kaxw.aspx をご覧ください。

  2. ご丁寧にありがとうございます。
    理解できました。
    早々のご回答、感謝いたします。

コメントを残す

以下に詳細を記入するか、アイコンをクリックしてログインしてください。

WordPress.com ロゴ

WordPress.com アカウントを使ってコメントしています。 ログアウト / 変更 )

Twitter 画像

Twitter アカウントを使ってコメントしています。 ログアウト / 変更 )

Facebook の写真

Facebook アカウントを使ってコメントしています。 ログアウト / 変更 )

Google+ フォト

Google+ アカウントを使ってコメントしています。 ログアウト / 変更 )

%s と連携中