2020年9月28日 / 最終更新日時 : 2021年12月30日 officeの杜 Microsoft365

Outlookで誤送信防止のVBA – Exchange Server対応

自分自身、メーラーを使ってメールを個別に送る事は大分前から少なくなっているので、メール誤送信は殆ど起こしたことが無いのですが、企業内では未だに多くのメール誤送信でトラブルが起きてる現場が多数あるみたいです。今回、VBAで送信前にチェックが出来るようにするVBAを作り、これを配布出来るようにしてみたいと思います。

ただ、昔と違い今は、あらゆるものをシステム化するのが簡単になったので、大量に個別の相手にメールを送るケースはメーラーなど使わないし、予めリストから社員番号を元に別のデータを紐つけて送るので、元データに別人のデータを入れてたなんて事がない限り、起こり得ないのですが、個別メール送信時にダブルチェックなんて無意味で無益な事に時間を費やすのは非生産的です。そもそも個別にメールを送るシーンを減らし、ダブルチェック不要とするデバッガー気質や職人芸を身に着けないと、結局は減らす事は出来ないとは思います（つまりトレーニング無くして、誤送信を減らす事は出来ない）。

1 今回使用するファイル
2 メール誤送信が起きる理由
3 ソースコード
4 Outlook VBAを配布する
5 関連リンク

今回使用するファイル

Outlook用VBAプロジェクトファイル（インストーラ）

今回は個人利用のOutlookではなく、企業で利用するExchange Serverでの利用を想定したものです。

メール誤送信が起きる理由

企業でメール誤送信が起きる理由は多数あります。中には論外なケースもありますが概ね以下の数点になるかと思います。

グループ内の場合はOutlookのアドレス欄はメアドではなく表示名だけが表示されているケースが多い（同姓同名の場合区別がつきにくい）
日本であるにも関わらず、名前.名字@ドメインといった形式で気取ってメアド作ってるケースが多いですが、名前で呼ばない日本の文化の場合、これもまた検索時の障害になっています（メアド検索時に、yamada_taro@hogehoge.comのケースだと、yamadaで検索できますが、taro_yamadaの場合、yamadaでは出てきません）。名字.名前@ドメインで作るようにしましょう
漢字で検索する人が非常に多い。これが誤送信の最も招く原因。サイトウという漢字だけでいくつあると思ってるの？アドレスで検索すべし
素直に届いたメールにReplyせずに、新規にメール作って返信する低スキルな人が多い。メールはスレッドで親メールに紐ついてるものなので、新規に作るのはそもそもマナー違反。そして、これがまた誤送信のスキを生んでいる
そもそもメールではなく、Teamsや専用のシステム（CRMやメール一括送信システム）を活用していない。500人に500パターンのメールを手動で送るとか正気ですか？
他のシステムとの連動でWEB APIを活用せず、結局人間が間に入ってメールを送ってる
相手にまずアクションを起こさせるような業務フローを構築していない（何でもかんでも受け手のこちらが、相手にしてあげる・・・・結果新規にメールを作るシーンを増やしてる）。フォームなどを活用して、なるべくこちらから新規アクションを起こさない体制が必要（特に未だに電話やらFAXといった低レベルデバイスが主役の所は、そういった連絡手段はグループ内では極限まで減らすべき）。
メール送信遅延機能を活用していないケース（30秒間気がつけば送信キャンセル出来るなどのアレ）
今回のプラグインも含まれますが、誤送信防止でワンステップ入れるようなソリューションがありますが、事実として誤送信減っていません。理由は単純で、「人間というのは慣れる」ということです。

人間という不確定要素と個人のスキルレベルに依存する以上は、メール誤送信はどこまで行っても防げない。のであるならば、その介入シーンを極限まで無くすのがメール誤送信を防ぐ最短の手段です。今回のコードのようなものはあくまでも補助的なものに過ぎず、小手先の手段です。

※ちなみに、メールアドレス自動補完オフであったり、アカウントに顔写真付けても誤送信防止には一切貢献しないのでこういったことを「誤送信防止」と称して行ってる企業はちょっとリテラシーが低すぎますね。

ソースコード

'メール送信時にメアドをExchange Serverから取得しチェックする
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    'エラートラップ
    On Error GoTo Exception
    
    'ToとCCを取得する
    Dim mailTo As String
    Dim mailCc As String
    Dim ccflg As Boolean
    Dim messagebox As String
    
    mailTo = Item.To
    mailCc = Item.CC
    
    '配列用変数
    Dim toarray, ccarray

'アドレスが入ってるかどうかチェック
    If mailTo = "" Then
        MsgBox "Toにアドレスが入っていません"
        Cancel = True
        Exit Sub
    Else
        'Toを配列に加える
        toarray = Split(mailTo, ";")
        
        If mailCc = "" Then
            ccflg = False
        Else
            ccflg = True
            ccarray = Split(mailCc, ";")
        End If
    End If
    
    'アドレスの個数をカウント
    Dim tocnt As Variant
    Dim cccnt As Variant
    Dim tonum As Integer
    Dim ccnum As Integer
    
    tocnt = UBound(toarray)

If ccflg = False Then
    Else
        cccnt = UBound(ccarray)
    End If

'Exchange Server問い合わせ用変数
    Dim oRecip As Outlook.Recipient
    Dim oEU As Outlook.ExchangeUser
    Dim oEDL As Outlook.ExchangeDistributionList
    Dim tempAddress As String
    Dim tempname As String
    Dim temptype As Integer
    
    'ループで調査する
    tonum = 0
    ccnum = 0
    For Each objRecipient In Item.Recipients
    
        '表示名を取得する
        tempname = objRecipient.Name
        
        '順次Exchange Serverに問い合わせ
        Set oRecip = Application.Session.CreateRecipient(tempname)
        oRecip.Resolve
        
        'Excange Serverのリストにあるかどうかチェック
        If oRecip.Resolved Then
            'Exchange Serverからメアドを取得
            Select Case oRecip.AddressEntry.AddressEntryUserType
                Case OlAddressEntryUserType.olExchangeUserAddressEntry
                    Set oEU = oRecip.AddressEntry.GetExchangeUser
                    If Not (oEU Is Nothing) Then
                        tempAddress = oEU.PrimarySmtpAddress
                    End If
                Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
                    Set oEDL = oRecip.AddressEntry.GetExchangeDistributionList
                    If Not (oEDL Is Nothing) Then
                        tempAddress = oEDL.PrimarySmtpAddress
                    End If
            End Select
        Else
            '外部宛なのでメアドを取得
            tempAddress = objRecipient.Address & " 【外部宛て】"
        End If
        
        '送信タイプで判定し、それぞれを配列に加える(1でTo、2でCc)
        temptype = objRecipient.Type
        
        If temptype = 1 Then
            'toArrayを書き換える
            toarray(tonum) = tempname & " ≫ " & tempAddress
            
            'カウントアップ
            tonum = tonum + 1
        Else
            'ccArrayを書き換える
            ccarray(ccnum) = tempname & " ≫ " & tempAddress
        
            'カウントアップ
            ccnum = ccnum + 1
        End If
    Next

'Toカウント配列からメッセージを生成する
    messagebox = "【To】▼ " & vbCrLf
    For i = 0 To tocnt
        messagebox = messagebox & toarray(i) & vbCrLf
    Next i
    
    'Ccカウント配列からメッセージを生成する
    If ccflg = True Then
        messagebox = messagebox & Chr(13) & Chr(13) & "【Cc】▼" & vbCrLf
        For j = 0 To cccnt
            messagebox = messagebox & ccarray(j) & vbCrLf
        Next j
    End If
    
    'アナウンスを追加
    messagebox = messagebox & Chr(13) & Chr(13) & "上記の宛先に送信します。本当に大丈夫ですか？？"
    
    '送信確認メッセージ
    If MsgBox(messagebox, vbYesNo + vbExclamation + vbDefaultButton2) <> vbYes Then
        Cancel = True
    End If
    
    Exit Sub

Exception:
    'エラー発生時の処理
    MsgBox CStr(Err.Number) & ":" & Err.Description, vbOKOnly + vbCritical
    Cancel = True
    Exit Sub

End Sub

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

'メール送信時にメアドをExchange Serverから取得しチェックする

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

'エラートラップ

On Error GoTo Exception

'ToとCCを取得する

Dim mailTo As String

Dim mailCc As String

Dim ccflg As Boolean

Dim messagebox As String

mailTo = Item.To

mailCc = Item.CC

'配列用変数

Dim toarray, ccarray

'アドレスが入ってるかどうかチェック

If mailTo = "" Then

MsgBox "Toにアドレスが入っていません"

Cancel = True

Exit Sub

Else

'Toを配列に加える

toarray = Split(mailTo, ";")

If mailCc = "" Then

ccflg = False

Else

ccflg = True

ccarray = Split(mailCc, ";")

End If

'アドレスの個数をカウント

Dim tocnt As Variant

Dim cccnt As Variant

Dim tonum As Integer

Dim ccnum As Integer

tocnt = UBound(toarray)

If ccflg = False Then

Else

cccnt = UBound(ccarray)

End If

'Exchange Server問い合わせ用変数

Dim oRecip As Outlook.Recipient

Dim oEU As Outlook.ExchangeUser

Dim oEDL As Outlook.ExchangeDistributionList

Dim tempAddress As String

Dim tempname As String

Dim temptype As Integer

'ループで調査する

tonum = 0

ccnum = 0

For Each objRecipient In Item.Recipients

'表示名を取得する

tempname = objRecipient.Name

'順次Exchange Serverに問い合わせ

Set oRecip = Application.Session.CreateRecipient(tempname)

oRecip.Resolve

'Excange Serverのリストにあるかどうかチェック

If oRecip.Resolved Then

'Exchange Serverからメアドを取得

Select Case oRecip.AddressEntry.AddressEntryUserType

Case OlAddressEntryUserType.olExchangeUserAddressEntry

Set oEU = oRecip.AddressEntry.GetExchangeUser

If Not (oEU Is Nothing) Then

tempAddress = oEU.PrimarySmtpAddress

End If

Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry

Set oEDL = oRecip.AddressEntry.GetExchangeDistributionList

If Not (oEDL Is Nothing) Then

tempAddress = oEDL.PrimarySmtpAddress

End If

End Select

Else

'外部宛なのでメアドを取得

tempAddress = objRecipient.Address & " 【外部宛て】"

End If

'送信タイプで判定し、それぞれを配列に加える(1でTo、2でCc)

temptype = objRecipient.Type

If temptype = 1 Then

'toArrayを書き換える

toarray(tonum) = tempname & " ≫ " & tempAddress

'カウントアップ

tonum = tonum + 1

Else

'ccArrayを書き換える

ccarray(ccnum) = tempname & " ≫ " & tempAddress

'カウントアップ

ccnum = ccnum + 1

End If

'Toカウント配列からメッセージを生成する

messagebox = "【To】▼ " & vbCrLf

For i = 0 To tocnt

messagebox = messagebox & toarray(i) & vbCrLf

Next i

'Ccカウント配列からメッセージを生成する

If ccflg = True Then

messagebox = messagebox & Chr(13) & Chr(13) & "【Cc】▼" & vbCrLf

For j = 0 To cccnt

messagebox = messagebox & ccarray(j) & vbCrLf

Next j

End If

'アナウンスを追加

messagebox = messagebox & Chr(13) & Chr(13) & "上記の宛先に送信します。本当に大丈夫ですか？？"

'送信確認メッセージ

If MsgBox(messagebox, vbYesNo + vbExclamation + vbDefaultButton2) <> vbYes Then

Cancel = True

End If

Exit Sub

Exception:

'エラー発生時の処理

MsgBox CStr(Err.Number) & ":" & Err.Description, vbOKOnly + vbCritical

Cancel = True

Exit Sub

End Sub

このコードは、ThisOutlookSessionに書く必要があります。
また、送信時イベントの名称はApplication_ItemSendとなります。これで送信時に自動的に呼び出されます。
複数ToやCcが入ってることを考慮する必要があるので、それぞれSplit関数でセミコロンを区切りとして配列化しておきます。
MS公式コードでExchange Serverに表示名を送りつけ、メールアドレスを取得します。他にも取得できそうな予感
Exchange Serverの場合、普通にReceipents.Addressだとオカシナ文字列が取得されるので使えません。
Exchange Serverに登録がない場合は、外部アドレスと判定し普通にReceipents.Addressでメアドを取得します。
配列に表示名+アドレスの塊で値を入れ込み、それを利用してメッセージを作成します。
objRecipient.Typeにて、Toなのか？Ccなのかの判定が可能。１ならTo、2ならCcとなります。
Cancel = Trueを使うことでキャンセルが実行された場合にコードの実行が中止されます。Exit Subだけだとメールが送信されてしまいます。
外部宛メアドには、外部向けの文字列を追加するようにしています。
ただし、通常のメッセージボックスだと表示に限界があるので、場合によってはUser.Formなどを使ってやり取りが必要かもしれません（すごく面倒ですが）

図：このようなダイアログが表示されるようになります

図：書く場所と書くルールに注意

Outlook VBAを配布する

注意点

Outlook VBAでは、Excelと異なりプラグインの作成が出来ません。VSTOプラグインであれば作成し簡単に配布は出来ますが、Visual Studioを使ってC#で記述が必要になります。そこまでしてOutlookプラグインを作るほどメリットあるかなぁというのが正直な意見。大規模システムと連携するようなケースならば価値はあると思いますが。

また、プラグインが作れない以上、１つのOutlookに配布出来るものは１つに限られてしまいます。つまり別のプロジェクトを既にインストールしてる場合上書きされてしまうので、常に１個のOTM形式のファイルを持って他のプロジェクトと含めての配布が必要になります。Excelのようなxlam形式で作れて配布できるなら最高なんですけれどね。

配布方法

作成したVBAはOutlookの特定のフォルダ内にOTMという拡張子でファイルが生成されているので、これを他のユーザの同じ場所に配置すれば利用可能になります。配置場所は以下の場所になります。ファイル名は「VbaProject.OTM」という名前になります。

1	C:\Users\ユーザ名\AppData\Roaming\Microsoft\Outlook

図：OTMがVBAプロジェクトの実体

このファイルを元にInno Setupでインストーラを作ってみます。変更点はインストール先の１箇所だけ。

1	DefaultDirName={userappdata}\Microsoft\Outlook

DefaultDirNameの値の指定に、{userappdata}を指定する事で、ユーザのAppDataのRoaming以下の指定になります。後はコンパイルしてEXEを作成すれば、インストーラで全ユーザ対象にVBAコードを手間なく配布する事が可能になります。

※実際にインストールする場合は、Outlookが起動していない状態（タスクトレイにも常駐していない状態）である必要があります。起動中はインストールは出来ません。

使用するにあたって

Outlook VBAをそのまま導入しても動作しません。動作させようとすると、毎回セキュリティ通知が出るようになります。これを回避するには、以下の２パターン

設定からマクロのセキュリティレベルを下げる
VBAにデジタル署名を追加して導入してもらうようにする

前者は、ファイル⇒オプション⇒セキュリティセンター⇒セキュリティセンターの設定⇒マクロの設定にあるレベルを「すべてのマクロを有効にする」にチェックをいれます。ただし、これはセキュリティレベルを下げる事になりますが、ExcelやWordと異なりOutlookはVbaProject.OTMからしかVBAが実行出来ないので、この設定でも過度に問題にはなりにくいです。

後者はVBAの作成画面にて以下の手順でデジタル署名を追加する方法です。