【Outlook VBA】送信前に入力した宛先に指定外ドメインが含まれるか確認する方法

メール誤送信は個人だけの問題ではなく会社や組織の信用を失う事態まで発展しかねない重大事故として取り扱われているケースが多いかと思います。

けど、いくら注意をしていたとしても、日々膨大なメールを利用していると、ヒヤリとする機会は多々あるでしょう。

今回は前回の「送信前に入力した宛先を確認するメッセージを表示する方法」に続き、指定外ドメインが含まれるかチェックする方法を紹介したいと思います。

【Outlook VBA】カンタンに送信前に入力した宛先を確認するメッセージを表示する

指定外ドメインが含まれるかチェックする意図について

メール誤送信はどの企業でも重大事故として取り扱われますが、その中でも特にインパクトが大きいことは社外へ情報が漏れてしまうことではないでしょうか。

その発生要因となるところは社外のアドレスにメールを送信する場合に起こります。パスワードなしの添付ファイルがあったならば被害はさらに拡大するでしょう。

一方でメール誤送信をした先が社内であった場合、当然影響範囲は社内にとどまるので被害は限定的ですね。

社外に送信させないか、限定する。

社外と位置付ける指定以外のドメインのメールアドレスが含まれるかどうかを送信前にチェックする意図はそこにあります。

指定外ドメインに対して制御を行うことによりリスクを抑えることができるのです。

指定外ドメインをチェックする方法について

今回の方法は、警戒をする必要がない、つまり社内ドメインなど安全であるドメイン一覧を用意して、そのドメインに該当しない場合は警告メッセージをメール送信前に表示する仕組みを採用しました。
ちなみにIT用語ではこの警戒をする必要がない一覧をホワイトリストと呼びます。反対に警戒が必要な一覧をブラックリストといいます。

なお、ブラックリスト方式はホワイトリスト方式に比べ汎用性がある一方で警戒する必要があるドメインを大量に用意しなければならず、ブラックリストに定義されていないドメインはスルーされてしまう欠点があります。

マクロを設置する下準備をする。

以下を参考にVBAコードを配置する場所を表示させます。

Outlook VBAをはじめよう！初心者向け手引き

マクロを登録する

「開発」タブ>「Visual Basic」を押します。

「Visual Basic Editor」にて、[Project1] > [Microsoft Outlook Objects] > [ThisOutlookSession] を開きます。

右のコードエリアへ、以下のコードを貼り付けて保存します。

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

    Dim mailTo As Variant
    Dim mailCc As Variant
    Dim WanMsg As String
    Dim WanMsg2 As String
    Dim myDomainList As Variant
    Dim myDomain As Variant
    Dim checkNum As Long
    Dim recips As Object
    Dim recip As Object
    Dim pa As Object
    Dim paAddr As Variant
    
    
    'チェックナンバー初期化
    checNum = 0
    
    '指定ドメイン（ホワイトリストです。カンマ区切りでドメインを追加することができます。）
    myDomainList = Array("extan.jp", "extan2.jp")
    
    'Itemオブジェクトから宛先を取得
    mailTo = Item.To
    mailCc = Item.CC

    '宛先を配列へ格納
    mailTo = Split(mailTo, ";")
    mailCc = Split(mailCc, ";")
    
    WanMsg = "▼宛先は" & vbCrLf
    
    For i = 0 To UBound(mailTo)
        WanMsg = WanMsg & "To:" & mailTo(i) & vbCrLf
    Next i
    
    For i = 0 To UBound(mailCc)
        WanMsg = WanMsg & "Cc:" & mailCc(i) & vbCrLf
    Next i
    
    'outlookオブジェクトの名前空間を指定
    Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
    
    Set recips = Item.Recipients
    
    'SMTPアドレスを取得
    For Each recip In recips
        Set pa = recip.PropertyAccessor
        
        'ホワイトリストに該当するドメインであるかチェック
        For Each myDomain In myDomainList
            If InStr(pa.GetProperty(PR_SMTP_ADDRESS), myDomain) <> 0 Then
                checkNum = checkNum + 1
            End If
        Next
        
        'ホワイトリストに含まれない場合は警告メッセージ変数に追記
        If checkNum = 0 Then
            WanMsg2 = WanMsg2 & "SMTP:" & pa.GetProperty(PR_SMTP_ADDRESS) & vbCrLf
        End If
        
        checkNum = 0
        
    Next
    
    WanMsg = WanMsg & "が含まれています。" & vbCrLf
    
    If WanMsg2 <> "" Then
    WanMsg = WanMsg & vbCrLf & "▼以下は指定外ドメインです。再確認してください。" & WanMsg2 & vbCrLf
    End If
    
    WanMsg = WanMsg & "上記宛先へメールを送信してもよろしいですか？" & vbCrLf & vbCrLf
    
    If MsgBox(WanMsg, vbYesNo + vbExclamation) = vbNo Then
        Cancel = True
        Exit Sub
    End If
    
    Set Item = Nothing

End Sub

試しにサンプルメールを作りチェックされるか確認をする

コードの説明はさておき、早速チェックされるか確認をしてみましょう。

適当なメールを作り、宛先、件名を入力します。
今回はホワイトリストにドメイン”extan.jp”, “extan2.jp”を指定していますので、それ以外のドメインがあれば警告メッセージが表示される結果となります。
なお、使用環境に合わせて上記ソースコードのホワイトリストのドメインおよびメール本体の宛先を変えれば、その条件で機能します。