【Outlook VBA】送信前に入力した宛先が指定外ドメインで、かつ添付ファイルがある場合は警告する方法

前回の「【Outlook VBA】カンタン！送信前に入力した宛先に指定外ドメインが含まれるか確認する」に続きメール誤送信対策として、添付ファイルが含まれる場合、送信前に警告メッセージを出すようにしたいと思います。

添付ファイルを送るときのリスクについて

メール誤送信はどの企業でも必ず発生しています。メールの件数は増大傾向であり人間が操作する以上ミスは避けられません。その中で添付ファイルがあった場合にはその情報量や内容に応じて深刻度が増していきます。さらに他社の情報であった場合は自社だけの問題ではなくなり、被害の範囲はどんどん拡大していきます。

添付ファイルが怖いところはもう一つあって、それは一度送ってしまったファイルを回収することは困難であることです。誤送信先のPCに保存される形となりますが、削除をする場合には基本的に所有者へお願いすることとなり、削除をしたかについては所有者のPCを確認しない限りわかりません。

そんなリスクの高い添付ファイルですが、社外のアドレスに添付ファイル付きのメールを送信する時に警告メッセージを表示させるか、そもそもメールを送信させないようににすれば未然に事故は防ぐことができるのです。

添付をチェックする方法について

今回は指定ドメインでない場合で、かつ添付ファイルを含んでいたら警告メッセージを出す仕様となります。
指定ドメインでない場合の判定は前回の方法を流用しますので、添付ファイルの有無のみを考えたいと思います。

まず添付ファイルはAttachmentsコレクション（添付ファイルの集合）内に記録されますので、そのオブジェクト数を取得するようにします。

Item.Attachments.Count

添付ファイルがなければ0件、あればその件数が出力されます。ですので、1件以上出力された場合に警告メッセージを作るようにします。

完成したマクロは以下の通りです。

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

以下を参考に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 WanMsg3 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
    
    '添付ファイルカウント
    If Item.Attachments.Count <> 0 Then
        WanMsg3 = "添付ファイルは" & Item.Attachments.Count & "件あります。"
    End If
    
    'チェックナンバー初期化
    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
        '添付ファイルがあった場合は警告メッセージを表示
        If WanMsg3 <> "" Then
            WanMsg = WanMsg & "▼添付ファイルは指定外ドメインへ送信できません。削除をしてください。" & vbCrLf & WanMsg3 & vbCrLf
            If MsgBox(WanMsg, vbOKOnly + vbExclamation) = vbOK Then
                 Cancel = True
                 Exit Sub
             End If
         End If
    
    End If
    
    WanMsg = WanMsg & "上記宛先へメールを送信してもよろしいですか？" & vbCrLf & vbCrLf
    
    If MsgBox(WanMsg, vbYesNo + vbExclamation) = vbNo Then
        Cancel = True
        Exit Sub
    End If
    
    Set Item = Nothing

End Sub