// Net planet-es V2

Outlookご送信防止策として、自社ドメイン以外のドメインがメールアドレスに含まれていた場合に警告メッセージを送付するマクロを作成しました。まったくオリジナルではなく、ここので紹介されていたマクロを参考に自分の要件にマッチするようにカスタマイズしました。

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
 Const MY_DOMAIN = "*@sample.net" ' 自組織のドメイン名を指定。@ の前に * を付ける
 Dim objRec As Recipient
 Dim bOut As Boolean
 Dim bExternal As Boolean
 Dim strOut As String
 Dim iRet As Integer
 ' 組織外の受信者が複数存在するかどうかの確認
 bMixed = False
 strOut = ""
 str1stDomain = ""
 For Each objRec In Item.Recipients
    If objRec.AddressEntry.Type <> "EX" Then
        If Not objRec.Address Like MY_DOMAIN And InStr(objRec.Address, "@") > 0 Then
           strOut = strOut & objRec.Address & ";"
           bExternal = True
        End If
    End If
 Next
 ' 組織外の受信者が複数含まれていた場合の処理
 If bExternal Then
    iRet = MsgBox("あて先に複数のドメインのメールアドレスが含まれています。送信しますか?" & _
                    vbCrLf & "外部ドメイン宛: " & strOut, vbYesNo, "送信確認")
     Select Case iRet
            Case vbYes
                ' 送信日時を 1 分後に設定
                Item.DeferredDeliveryTime = DateAdd("n", 1, Now)
                Cancel = False ' 念のため
            Case vbNo
            Cancel = True
    End Select
 End If
End Sub

マクロを登録する方法は、参考にさせていただいたサイトのこのページを利用すればOKです。

ただし、自己署名のデジタル証明書作成ツールはページに指定された方法で見つけられなかったので、Office 2016の場合は、C:\Program Files (x86)\Microsoft Office\root\Office16\SELFCERT.EXE を直接実行します。