【Outlook VBA】送信前に入力した宛先が指定外ドメインの場合は送信させない方法

前回の「【Outlook VBA】カンタン！送信前に入力した宛先が指定外ドメインで、かつ添付ファイルがある場合は警告する」ですが、の警告メッセージで終わらせるのではなく禁止させたい要望がありましたので、送信禁止にするようカスタマイズしてみたいと思います。

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

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

以下を参考に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 & "▼以下は指定外ドメインです。送信できません。" & vbCrLf & WanMsg2 & vbCrLf
        Cancel = True
        If WanMsg3 <> "" Then
            WanMsg = WanMsg & "▼添付ファイルは指定外ドメインへ送信できません。" & vbCrLf & WanMsg3 & vbCrLf
            Cancel = True
         End If
    End If
    
    If Cancel = True Then
        MsgBox (WanMsg)
        Exit Sub
    End If
    
    WanMsg = WanMsg & "上記宛先へメールを送信してもよろしいですか？" & vbCrLf & vbCrLf
    
    If MsgBox(WanMsg, vbYesNo + vbExclamation) = vbNo Then
        Cancel = True
        Exit Sub
    End If
    
    Set Item = Nothing

End Sub