件名に含まれるキーワードにより送信警告の表示を制御するマクロ(複数ドメイン バージョン)


件名に含まれるキーワードにより送信警告の表示を制御するマクロのコメントにて以下のご要望をいただきました。


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

上記マクロ内の「Const MyDomain 」を複数設定することは可能でしょうか。
いくつか検索してみましたが、該当のページが見つけられなかったため、問い合わせした次第です。

お手数おかけいたしますが、よろしくお願いいたします。


ドメインを複数設定する必要がある場合、宛先アドレスのドメインチェックの際に For 文でドメイン文字列とのマッチングを行う必要があります。
元のマクロを複数ドメインに対応するよう修正したものは以下の通りです。
なお、このマクロが正常に動作するには、件名に含まれるキーワードにより送信警告の表示を制御するマクロで説明しているフォルダー設定などが必要になります。

' ここをトリプルクリックでマクロ全体を選択できます。
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 = "@us.example.com;@jp.example.com"
     ' SMTP アドレスを格納する MAPI プロパティの TAG です。URL ではありません。
     Const PR_SMTP_ADDRESS = "http:" & "//schemas.microsoft.com/mapi/proptag/0x39FE001E"
     Dim arrMyDomain As Variant
     Dim i As Integer
     Dim j As Integer
     Dim strAddress As String
     Dim strExtAddr As String
     Dim bExternal As Boolean
     ' ; でドメイン文字列を分割し配列に格納
     arrMyDomain = Split(MyDomain, ";")
     '
     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
             ' 自ドメインのアドレスでない場合は bExternal は True
             bExternal = True
             For j = LBound(arrMyDomain) To UBound(arrMyDomain)
                 ' 自ドメインのアドレスであれ場合は bExternal は True
                 If strAddress Like "*" & arrMyDomain(j) Then
                     bExternal = False
                     Exit For
                 End If
             Next
             ' bExternal が True なら社外アドレス
             If bExternal 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

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

広告

コメントを残す

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

WordPress.com ロゴ

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

Google フォト

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

Twitter 画像

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

Facebook の写真

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

%s と連携中