Outlookで誤送信防止のVBA – Exchange Server対応 🌴 officeの杜 🥥

自分自身、メーラーを使ってメールを個別に送る事は大分前から少なくなっているので、メール誤送信は殆ど起こしたことが無いのですが、企業内では未だに多くのメール誤送信でトラブルが起きてる現場が多数あるみたいです。今回、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」という名前になります。

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

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

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

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

DefaultDirName={userappdata}\Microsoft\Outlook

1	DefaultDirName={userappdata}\Microsoft\Outlook

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

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

使用するにあたって

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

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

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

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

Outlookの開発タブ⇒Visual Basicを開く（開発タブが表示されていない場合は設定から表示する）
C:\Program Files\Microsoft Office\root\Office16の下にあるSELFCERT.EXEを起動する
デジタル署名の作成が出てくるので、適当な名前を入れてOKをクリック
VBAの作成画面に戻り、ツール⇒デジタル署名をクリック
選択をクリックすると、作成したデジタル証明書が出てきます。詳細で複数の証明書から選択も可能
OKをクリックするとデジタル証明書が適用されます。

ただしこの方法はユーザごとに必要で証明書付きでVBAプロジェクトの配布が出来ません。Excel VBAと異なりこの辺が面倒ですね。

図：毎回出てくるセキュリティ通知

図：マクロのセキュリティレベル変更画面

図：デジタル署名の作成画面

MENU

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

今回使用するファイル

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

ソースコード

Outlook VBAを配布する

注意点

配布方法

使用するにあたって

関連リンク

コメントを残すコメントをキャンセル

検索

最近の投稿

表示数

G Suite関連リンク

目次

スポンサーリンク

MENU

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

今回使用するファイル

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

ソースコード

Outlook VBAを配布する

注意点

配布方法

使用するにあたって

関連リンク

関連記事:

コメントを残す コメントをキャンセル

検索

最近の投稿

表示数

G Suite関連リンク

目次

スポンサーリンク

　関連記事:

コメントを残すコメントをキャンセル