[Outlook VBA]メール送信前チェック

やりたいこと

• 添付ファイルを送るつもりで本文を書いたのに、肝心のファイルを添付し忘れた。
• 外部に添付ファイルを送信する時は上長をCCに入れなきゃいけないのに、そのまま送ってフィルタに弾かれた。
• 件名を付け忘れて無題で送信した(※いつからかOutlookの標準機能でチェックできるようになった)。

あまりに繰り返す自分に心底呆れたので、VBAでチェックすることにしました。

仕様

チェック仕様

• 件名未入力チェック(標準機能にあるためコメントアウト)

  • 件名が空白(スペースのみの場合も)の場合に確認メッセージを表示

• 添付ファイル未登録チェック

  • 以下の条件にあてはまる場合に確認メッセージを表示
    • 件名、本文に「添付」の文字が入力されている
    • 添付ファイルが1件も添付されていない

• 添付ファイル送信時上長存在チェック

  • 以下の条件にあてはまる場合に確認メッセージを表示
    • 宛先のメールアドレスに送信者のドメインと異なるドメインが含まれる
    • 添付ファイルが1件以上添付されている
  • 上記のメッセージで[はい]を選択すると、設定された上長のアドレスをCCに自動付与する

動作環境

• Outlook2016
  たぶんもっと前のバージョンでも動作します。

• Microsoft Exchange
  アドレスの名前解決等を行っています。

設定方法

1. [開発]タブから[Visual Basic]を選択し、Visual Basic for Applicationsを起動する。
2. 左側[プロジェクト]から[ThisOutlookSession]をダブルクリックし、VbaProject.OTM - ThisOutlookSession(コード)を開く。
3. 以下のソースをコピー&ペーストし、Visual Basic for Applicationを終了する。

※[開発]タブが表示されていない場合、以下の方法で表示する。
- [ファイル]-[オプション]でOutlookのオプションを開く。
- 左側から[リボンのユーザー設定]を選択し、右側[リボンのユーザー設定]でメインタブ[開発]にチェックを入れる。

ソース

最後のデバッグ用2行からコメントアウトを外せばどんな条件でも送信されなくなり、デバッグ実行時の誤送信を防げます。

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

    ' メッセージ
    Dim strMsg As String

'    ' 件名の未入力チェック(標準機能にあるためコメントアウト)
'    If Trim(Item.Subject) = "" Then
'        '件名が空白の場合、確認ダイアログを表示
'        strMsg = "このメッセージを件名なしで送信しますか？"
'
'        If MsgBox(strMsg, vbYesNo + vbExclamation) = vbNo Then
'            '「いいえ」の場合、送信を取り止め
'            Cancel = True
'
'            Exit Sub
'        End If
'    End If

    ' 添付ファイル未登録チェック
    If InStr(Item.Subject & Item.Body, "添付") > 0 And Item.Attachments.Count = 0 Then
        ' 件名または本文に「添付」の文字があり、添付ファイルが0件の場合、確認ダイアログを表示
        strMsg = "メッセージ中に「添付」の文字があります。" & vbCrLf & _
                 "このメッセージを添付ファイルなしで送信しますか？"

        If MsgBox(strMsg, vbYesNo + vbExclamation) = vbNo Then
            ' 「いいえ」の場合、送信を取り止め
            Cancel = True

            Exit Sub
        End If
    End If

    ' 外部への送信でファイル添付時上長未選択チェック
    If Item.Attachments.Count > 0 Then
        ' 添付ファイルが1件以上ある場合

        ' 送信者ドメイン(送信者アドレスの@以降)
        Dim strDomain As Variant
        strDomain = Split(Item.Session.CurrentUser.Address, "@")

        ' 外部ドメイン送信フラグ
        Dim extDomainFlg As Boolean
        extDomainFlg = False

        ' 上長設定済フラグ
        Dim superiorFlg As Boolean
        superiorFlg = False

        ' 宛先リスト
        Dim RecipientList As Recipients
        Set RecipientList = Item.Recipients

        ' 宛先リストに外部ドメインが含まれるかをチェック
        Dim Recipient As Recipient
        For Each Recipient In RecipientList
            If Recipient.AddressEntry.Type <> "EX" Then
                '宛先がExchangeユーザでない場合
                If Not (Recipient.Address Like "*" & strDomain(UBound(strDomain))) Then
                    'アドレスに送信者ドメインが含まれない場合、外部ドメイン送信フラグをTrueにして終了
                    extDomainFlg = True

                    Exit For
                End If
            End If
        Next Recipient

        If extDomainFlg Then
            ' 外部ドメイン送信フラグがTrueの場合

            ' 上長リスト
            Dim superiorNameList() As String
            Dim superiorAddressList() As String

            ' 上長リストの最初はCCに自動設定する上長とする
            ReDim superiorNameList(0)
            ReDim superiorAddressList(0)
            superiorNameList(0) = "上長 太郎"
            superiorAddressList(0) = "[e-mail]"

            ReDim Preserve superiorNameList(UBound(superiorNameList) + 1)
            ReDim Preserve superiorAddressList(UBound(superiorAddressList) + 1)
            superiorNameList(UBound(superiorNameList)) = "部長 一郎"
            superiorAddressList(UBound(superiorAddressList)) = "[e-mail]"

            ReDim Preserve superiorNameList(UBound(superiorNameList) + 1)
            ReDim Preserve superiorAddressList(UBound(superiorAddressList) + 1)
            superiorNameList(UBound(superiorNameList)) = "課長 二郎"
            superiorAddressList(UBound(superiorAddressList)) = "[e-mail]"

            ReDim Preserve superiorNameList(UBound(superiorNameList) + 1)
            ReDim Preserve superiorAddressList(UBound(superiorAddressList) + 1)
            superiorNameList(UBound(superiorNameList)) = "筆頭上席副係長補佐代理代行見習心得付待遇 三郎"
            superiorAddressList(UBound(superiorAddressList)) = "[e-mail]"

            ' 宛先リストに上長が存在するかをチェック
            For Each Recipient In RecipientList
                ' 上長名リストでチェック
                Dim superiorName As Variant
                For Each superiorName In superiorNameList
                    If Recipient.Name = superiorName Then
                        ' 送信先名が上長名リストに含まれる場合、上長設定済フラグをTrueにしてチェック終了
                        superiorFlg = True

                        Exit For
                    End If
                Next superiorName

                ' 上長設定済フラグがTrueになっている場合、チェック終了
                If superiorFlg Then Exit For

                ' 上長アドレスリストでチェック
                Dim superiorAddress As Variant
                For Each superiorAddress In superiorAddressList
                    If Recipient.Address = superiorAddress Then
                        ' 送信先アドレスが上長アドレスリストに含まれる場合、上長設定済フラグをTrueにしてチェック終了
                        superiorFlg = True

                        Exit For
                    End If
                Next superiorAddress

                ' 上長設定済フラグがTrueになっている場合、チェック終了
                If superiorFlg Then Exit For
            Next Recipient

            If Not superiorFlg Then
                ' 外部ドメイン送信フラグがTrueで上長設定済フラグがFalseの場合、確認ダイアログを表示
                strMsg = "外部ドメインに対して暗号化された添付ファイルを送信する場合、宛先に上長を含める必要があります。" & vbCrLf & _
                         "CCに上長を設定しますか？"

                If MsgBox(strMsg, vbYesNo + vbExclamation) = vbYes Then
                    ' 「はい」の場合、送信を取り止めてCCに上長を設定
                    Cancel = True

                    ' CCに上長リスト最初の名前を追加
                    Dim superiorCc As Recipient
                    Set superiorCc = Item.Recipients.Add(superiorNameList(0))
                    superiorCc.Type = olCC
                    superiorCc.Resolve
                    Set superiorCc = Nothing

                    Exit Sub
                Else
                    ' 「いいえ」の場合、送信確認ダイアログを表示
                    strMsg = "このメッセージをそのまま送信しますか？"

                    If MsgBox(strMsg, vbYesNo + vbQuestion) = vbNo Then
                        ' 「いいえ」の場合、送信を取り止め
                        Cancel = True

                        Exit Sub
                    End If
                End If
            End If
        End If
    End If

'    ' デバッグ用
'    MsgBox "テスト中のため送信しません。", vbCritical
'    Cancel = True

End Sub

解説

Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

Outlookでメールや予定などのアイテムが送信される際に呼び出されるイベントです。
内部で引数CancelにTrueを設定した状態で終了すると、アイテムの送信は行われません。