【仕事で残念な人にならないために】Outlookメール誤送信チェックマクロ【冷汗防止】

ファイル名： -

©stockimages

概要

Outlook でメール誤送信をしてしまわないか不安なときに使えるマクロです。

用途

以下の様な冷や汗をかく経験をしないように、ちょっと立ち止まって再チェックを促すマクロです。

呼び捨てでメール送信してしまった。
受信するつもりで間違えて、送信してしまった。
添付ファイルを付けてしまった/忘れた。
メール本文の出だしが唐突だったり、自分しかわからない内容で相手にはわかりづらかった。
内部ではなく、外部向けMLも宛先に入っていた。

※ほんと、考えるだけで恐ろしい。。。((((；ﾟДﾟ))))ｶﾞｸｶﾞｸﾌﾞﾙﾌﾞﾙ

機能

(マクロが有効になっている時に)普段のメール送信ボタン押下後、実際にOutlookがメール送信する前に様々なチェックをサポートして、ユーザに再確認を促すダイアログを出現させます。

機能：メールチェック、無意識送信防止

主なチェック項目：件名、宛先（外部アドレス）、敬称、添付忘れチェック、重要文言（下図参照）

以前は忙しいと、月1回あるかないかで微妙なメールを送ることがよくありましたが、ミスするたびにこのマクロを改造したりして、そのような体験はほぼなくなってきました。仮にメール送信時マクロによって焦ってると気づいた時は、心を落ち着かせ今一度宛先、件名、本文の出だし、本文の宛先などを指差し確認しています。

［補足］マクロ登録先について

2007 はExcelオプション → 基本設定から、2010はクイックタブのあたりを右クリックして設定画面に遷移し、リボンの設定から開発タブを表示させる設定をすると開発タブがでてきます。そこにある Visual Basic Editorから (& セキュティ許可をして）使うことができます。
毎回起動時に許可するのは面倒ですが。。

マクロソースの貼り付け場所は、開発タブの Visual Basic Editor から OutlookのThisOutlookSession にApplication_ItemSend のSub関数を貼り付けておきます。そうすると送信ボタンを押して、フォルダ格納時にマクロがOutlookにより自動で起動されます。（テストとして、試しに自分宛てに空メール等を送ってみてください）

FAQ

ダイアログが出ず、マクロが実行されてないようであれば以下の3つの直接原因が考えられます。

セキュリティ上マクロ実行が無効になっている→マクロのセキュリティを変更する。
マクロが読まれていない→Outlookアプリケーションを再起動して、読み込みを許可させる（ダイアログが出ると思います）。
ThisOutlookSession に記載されておらず、送信時に実行されない→適切な場所にマクロのソースを貼り付けます。

［補足］セキュリティオプションの設定

マクロを動作させるには、Outlookのセキュリティオプションを設定しておく必要があります。
（例：Outlook 2013,2010)

↓これによって、Outlookの起動時にダイアログが表示されるようになるので、「マクロを有効にする」をクリックして起動します。

「ファイル」タブで「オプション」を選択
「セキュリティセンター」から、「セキュリティセンターの設定」ボタン
「マクロの設定」を選択し、「すべてのマクロに対して警告を表示する」をチェックON

その他おまけ等

その他の改造例

送信者が特定の時チェックする（メールボックスを複数持っている時向け）
宛先にMLが入っていたらチェックする
bccに必ず自分のメールアドレスを設定させる

その他メール全般のお薦めテク

送受信ボタンは右端において、返信や送信ボタンは左に置くようレイアウトする。→誤送信をかなりしにくくなります。
新規作成などメール作成ウィンドウでをメール送信しても、直ちに送信しないよう（設定ができるのであれば）設定する。送信フォルダに格納されるだけ。
送信フォルダ格納後、メールビューウィンドウの送受信ボタンで送信する。

参考

これもおすすめ

作業効率技の、次のページもどうぞ

Outlook

作業効率化！メール本文からスケジュール登録をワンクリックで行うマクロ-outlook
メール本文の分断されたパスをワンクリックで開く！
- 【あなたの思考を邪魔しない】仕事効率アップ！！【Outlook活用マクロ】
Outlook使う上で作業効率のためのおすすめ設定【ビジネスハック】
【さくっと】定期開催されるOutlookスケジュールを一覧で出力するマクロ
Outlookでの仕事効率技５連発！

Excel

マクロソース

GitHub上でどんどん改造しちゃってください(MIT Licence)。

Git使い慣れていないとわかりづらいかもしれませんが、
CheckSendingMail プロジェクト > CheckSendingMail.txt にマクロソースは入っています。

Public Function warning_exit(flag As Boolean, warning As String) As Boolean
  If flag = True Then
    If MsgBox(warning, vbOKCancel + vbExclamation) = vbCancel Then
      Cancel = True
    End If
  End If
  warning_exit = Cancel
End Function

Function include_check_words(includeCheck As Boolean, contents As String, includewordset As String) As Boolean
  Dim foundflag As Boolean

  includewords = Split(includewordset, ",")
  foundflag = False
  For i = LBound(includewords) To UBound(includewords)
    If InStr(contents, includewords(i)) > 0 Then
      foundflag = True
      Exit For
    End If
  Next i
  include_check_words = (includeCheck = foundflag)
End Function

Private Sub Application_AdvancedSearchComplete(ByVal SearchObject As Search)

End Sub

Private Sub Application_BeforeFolderSharingDialog(ByVal FolderToShare As MAPIFolder, Cancel As Boolean)

End Sub

'メール送信時にチェックするマクロ
'   機能：メールチェック、メール保存
'   主なチェック項目：件名、宛先（外部アドレス）、敬称、添付、重要文言
'

Private Sub Application_ItemSend(ByVal item As Object, Cancel As Boolean)
  'userセッティング
  Dim MyDomain As String
  Dim existExternAddress As Boolean
  Dim apdMsg As String
  Dim subContentsStr As String

  '一時保持
  Dim cnt As Integer
  Dim strAddress As String
  Dim strSubject As String
  Dim contents As String

  'for output
  Dim fileNames As String
  Dim message As String
  Dim externAdd As String

  'temp
  Dim i As Integer
  Dim flag As Boolean


  If TypeOf item Is Outlook.MailItem Then
    'MsgBox ("prop:" & item & " Mail! ")
  Else
    Exit Sub '会議の場合
  End If
  ' 初期値
  MyDomain = "jp.ec.com"  '＜自社のドメインなど＞
  MyDomainSecond = "n.co.jp"  '＜自社のドメインなど＞


  apdMsg = vbCrLf & "キャンセルを選択すると送信を中断します。"

  cnt = item.Attachments.Count    ' 添付ファイル数
  strSubject = item.Subject
  strBody = item.Body

  'MsgBox (cnt & " " & strSubject & vbCrLf & strBody)

  ' メールを保存する
  item.Save

  ' 宛先なしチェック  ' Outlook 2010などは 標準機能でチェックされます。
  message = message & "1/7 "

  If item.To = "" Then
     message = message & "[NG]:宛先がありません！"
  Else
     message = message & "[OK]:宛先"
  End If

  ' 件名なしチェック ' Outlook 2010などは 標準機能でチェックされます。
  message = message & vbCrLf & "2/7 "
  If strSubject = "" Then
     message = message & "[NG]:このメッセージには件名がありません。"
  Else
     message = message & "[OK]:件名あり"
  End If
  If InStr(strSubject, "UNCHECKED") > 0 Then
    message = message & "(余計な文字あり)"
  End If

  contents = strSubject & strBody

  ' 添付ファイルチェック
  message = message & vbCrLf & "3/7 "
  flag = False
  If cnt = 0 Then
    fileNames = "添付ファイル無し"
    flag = include_check_words(True, contents, "添付,圧縮,xls,ppt,doc,zip")
    If flag = True Then
       message = message & "[WARN]:添付ファイルを忘れている可能性があります。"
    Else
       message = message & "[OK]:添付忘れチェック(添付, zipなどのキーワードなし)"
    End If
  Else
    For i = 1 To cnt
      fileNames = fileNames & "添付" & i & "：" & item.Attachments.item(i).FileName & vbCrLf
    Next i
    message = message & "[OK]:添付忘れチェック(" & cnt & "件添付)"
  End If

  ' 要注意ワードチェック
  message = message & vbCrLf & "4/7 "
  flag = False
  flag = include_check_words(True, contents, "見積,予算,契約,厳禁,金額,内緒,内々") 'Confidential
  If flag = True Then
     message = message & "[WARN]:要注意メール!!:重要なメールではありませんか？" & vbCrLf & "    宛先や添付ファイル等を確認して下さい。"
  Else
     message = message & "[OK]:要注意ワードチェック"
  End If

  ' 敬称ワードチェック
  message = message & vbCrLf & "5/7 "
  subContentsStr = ""
  flag = False
  includewords = Split(strBody, ",")
  m = UBound(includewords)
  If mi > 10 Then
    mi = 10
  End If
  For i = LBound(includewords) To mi
    subContentsStr = subContentsStr & includewords(i)
  Next
  flag = include_check_words(False, subContentsStr, "さん,様,殿,各位,担当者,どの")
  If flag = True Then
     message = message & "[WARN]:敬称(様、さんなど)がもれて呼び捨てにしていませんか？"
  Else
     message = message & "[OK]:敬称チェック"
  End If

  ' 社外アドレスチェック
  message = message & vbCrLf & "6/7 "
  existExternAddressName = ""
  existExternAddress = False
  myadrflag = False

  For i = 1 To item.Recipients.Count
    With item.Recipients.item(i)
      strAddress = .Address
      If Not (strAddress Like "*" & MyDomain & "*" Or _
          strAddress Like "*" & MyDomainSecond & "*" _
          ) Then
        existExternAddress = True
        existExternAddressName = existExternAddressName & strAddress & " "
      End If
      
       
      
      'MsgBox strAddress & "," & myAddress & " | " _
      '& (myAddress = strAddress) & "," & (strAddress = myAddress)
      If strAddress = myAddress Then
        myadrflag = True
      End If
    End With
  Next

  StartTime = Now
  If existExternAddress = True Then
    externAdd = "外部メールアドレス：有(" & existExternAddressName & ")"
    message = message & "[WARN]:外部メールアドレスが宛先にあります。"
  Else
     externAdd = "外部メールアドレス：なし"
     message = message & "[OK]:外部アドレスチェック"
  End If
  
  message = message & vbCrLf & "   "
  If myadrflag = True Then
        message = message & "([OK]:my address あり)"
    Else
        message = message & "([WARN]:my address無し)"
  End If

  flag = warning_exit(True, message & vbCrLf & apdMsg)
  If flag = True Then
    Cancel = True
    Exit Sub
  End If

  ' 表示メッセージ
  message = "7/7 最終確認です。送信する前に再度宛先、件名、添付ファイル、本文の書き出し等確認してください。" & vbCrLf & _
    "送信者:" & appendList(item.Session.CurrentUser.Address) & vbCrLf & _
    fileNames & vbCrLf & _
    externAdd & vbCrLf & vbCrLf & _
    "[To]:" & appendList(item.To) & vbCrLf & _
    "[CC]:" & appendList(item.CC) & vbCrLf & _
    "[BCC]:" & appendList(item.BCC) & vbCrLf


  If MsgBox(message, vbOKCancel + vbExclamation) = vbCancel Then
    Cancel = True
    Exit Sub
  End If


  Do While DateDiff("s", StartTime, Now) < 3.7 '4秒位内なら再確認
    If MsgBox("焦らず確認しましょう" & vbCrLf & message, vbOKCancel + vbExclamation) = vbCancel Then
      Cancel = True
      Exit Sub
    End If
  Loop

  If (Hour(Now) >= 11 And Hour(Now) <= 13) Or (Hour(Now) >= 18) Then
    MsgBox ("送信フォルダに格納します。" & vbCrLf & "送信確認してください。")
  End If
End Sub
' 宛先などのアドレスを見やすくする関数
Private Function appendList(strName As String)
    Dim re As RegExp
    Dim mc As MatchCollection
        
    Set re = New RegExp
    re.Global = True
    
    re.Pattern = "[ ]*;[ ]*"
    strName = re.Replace(strName, vbCrLf)

    re.Pattern = "/.*cn=([^/]+)"
    appendList = re.Replace(strName, "$1")

End Function

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

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

Public Function warning_exit(flag As Boolean, warning As String) As Boolean

If flag = True Then

If MsgBox(warning, vbOKCancel + vbExclamation) = vbCancel Then

Cancel = True

End If

warning_exit = Cancel

End Function

Function include_check_words(includeCheck As Boolean, contents As String, includewordset As String) As Boolean

Dim foundflag As Boolean

includewords = Split(includewordset, ",")

foundflag = False

For i = LBound(includewords) To UBound(includewords)

If InStr(contents, includewords(i)) > 0 Then

foundflag = True

Exit For

End If

Next i

include_check_words = (includeCheck = foundflag)

End Function

Private Sub Application_AdvancedSearchComplete(ByVal SearchObject As Search)

End Sub

Private Sub Application_BeforeFolderSharingDialog(ByVal FolderToShare As MAPIFolder, Cancel As Boolean)

End Sub

'メール送信時にチェックするマクロ

' 機能：メールチェック、メール保存

' 主なチェック項目：件名、宛先（外部アドレス）、敬称、添付、重要文言

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

'userセッティング

Dim MyDomain As String

Dim existExternAddress As Boolean

Dim apdMsg As String

Dim subContentsStr As String

'一時保持

Dim cnt As Integer

Dim strAddress As String

Dim strSubject As String

Dim contents As String

'for output

Dim fileNames As String

Dim message As String

Dim externAdd As String

'temp

Dim i As Integer

Dim flag As Boolean

If TypeOf item Is Outlook.MailItem Then

'MsgBox ("prop:" & item & " Mail! ")

Else

Exit Sub '会議の場合

End If

' 初期値

MyDomain = "jp.ec.com" '＜自社のドメインなど＞

MyDomainSecond = "n.co.jp" '＜自社のドメインなど＞

apdMsg = vbCrLf & "キャンセルを選択すると送信を中断します。"

cnt = item.Attachments.Count ' 添付ファイル数

strSubject = item.Subject

strBody = item.Body

'MsgBox (cnt & " " & strSubject & vbCrLf & strBody)

' メールを保存する

item.Save

' 宛先なしチェック ' Outlook 2010などは標準機能でチェックされます。

message = message & "1/7 "

If item.To = "" Then

message = message & "[NG]:宛先がありません！"

Else

message = message & "[OK]:宛先"

End If

' 件名なしチェック ' Outlook 2010などは標準機能でチェックされます。

message = message & vbCrLf & "2/7 "

If strSubject = "" Then

message = message & "[NG]:このメッセージには件名がありません。"

Else

message = message & "[OK]:件名あり"

End If

If InStr(strSubject, "UNCHECKED") > 0 Then

message = message & "(余計な文字あり)"

End If

contents = strSubject & strBody

' 添付ファイルチェック

message = message & vbCrLf & "3/7 "

flag = False

If cnt = 0 Then

fileNames = "添付ファイル無し"

flag = include_check_words(True, contents, "添付,圧縮,xls,ppt,doc,zip")

If flag = True Then

message = message & "[WARN]:添付ファイルを忘れている可能性があります。"

Else

message = message & "[OK]:添付忘れチェック(添付, zipなどのキーワードなし)"

End If

Else

For i = 1 To cnt

fileNames = fileNames & "添付" & i & "：" & item.Attachments.item(i).FileName & vbCrLf

Next i

message = message & "[OK]:添付忘れチェック(" & cnt & "件添付)"

End If

' 要注意ワードチェック

message = message & vbCrLf & "4/7 "

flag = False

flag = include_check_words(True, contents, "見積,予算,契約,厳禁,金額,内緒,内々") 'Confidential

If flag = True Then

message = message & "[WARN]:要注意メール!!:重要なメールではありませんか？" & vbCrLf & " 宛先や添付ファイル等を確認して下さい。"

Else

message = message & "[OK]:要注意ワードチェック"

End If

' 敬称ワードチェック

message = message & vbCrLf & "5/7 "

subContentsStr = ""

flag = False

includewords = Split(strBody, ",")

m = UBound(includewords)

If mi > 10 Then

mi = 10

End If

For i = LBound(includewords) To mi

subContentsStr = subContentsStr & includewords(i)

flag = include_check_words(False, subContentsStr, "さん,様,殿,各位,担当者,どの")

If flag = True Then

message = message & "[WARN]:敬称(様、さんなど)がもれて呼び捨てにしていませんか？"

Else

message = message & "[OK]:敬称チェック"

End If

' 社外アドレスチェック

message = message & vbCrLf & "6/7 "

existExternAddressName = ""

existExternAddress = False

myadrflag = False

For i = 1 To item.Recipients.Count

With item.Recipients.item(i)

strAddress = .Address

If Not (strAddress Like "*" & MyDomain & "*" Or _

strAddress Like "*" & MyDomainSecond & "*" _

) Then

existExternAddress = True

existExternAddressName = existExternAddressName & strAddress & " "

End If

'MsgBox strAddress & "," & myAddress & " | " _

'& (myAddress = strAddress) & "," & (strAddress = myAddress)

If strAddress = myAddress Then

myadrflag = True

End If

End With

StartTime = Now

If existExternAddress = True Then

externAdd = "外部メールアドレス：有(" & existExternAddressName & ")"

message = message & "[WARN]:外部メールアドレスが宛先にあります。"

Else

externAdd = "外部メールアドレス：なし"

message = message & "[OK]:外部アドレスチェック"

End If

message = message & vbCrLf & " "

If myadrflag = True Then

message = message & "([OK]:my address あり)"

Else

message = message & "([WARN]:my address無し)"

End If

flag = warning_exit(True, message & vbCrLf & apdMsg)

If flag = True Then

Cancel = True

Exit Sub

End If

' 表示メッセージ

message = "7/7 最終確認です。送信する前に再度宛先、件名、添付ファイル、本文の書き出し等確認してください。" & vbCrLf & _

"送信者:" & appendList(item.Session.CurrentUser.Address) & vbCrLf & _

fileNames & vbCrLf & _

externAdd & vbCrLf & vbCrLf & _

"[To]:" & appendList(item.To) & vbCrLf & _

"[CC]:" & appendList(item.CC) & vbCrLf & _

"[BCC]:" & appendList(item.BCC) & vbCrLf

If MsgBox(message, vbOKCancel + vbExclamation) = vbCancel Then

Cancel = True

Exit Sub

End If

Do While DateDiff("s", StartTime, Now) < 3.7 '4秒位内なら再確認

If MsgBox("焦らず確認しましょう" & vbCrLf & message, vbOKCancel + vbExclamation) = vbCancel Then

Cancel = True

Exit Sub

End If

Loop

If (Hour(Now) >= 11 And Hour(Now) <= 13) Or (Hour(Now) >= 18) Then

MsgBox ("送信フォルダに格納します。" & vbCrLf & "送信確認してください。")

End If

End Sub

' 宛先などのアドレスを見やすくする関数

Private Function appendList(strName As String)

Dim re As RegExp

Dim mc As MatchCollection

Set re = New RegExp

re.Global = True

re.Pattern = "[ ]*;[ ]*"

strName = re.Replace(strName, vbCrLf)

re.Pattern = "/.*cn=([^/]+)"

appendList = re.Replace(strName, "$1")

End Function

SCAITY(スケイティー)

Share good Code And IT power with You intrinsically for harmony （旧：しょぼしょぼすくりぷと）

【仕事で残念な人にならないために】Outlookメール誤送信チェックマクロ【冷汗防止】

概要

用途

機能

［補足］マクロ登録先について

FAQ

［補足］セキュリティオプションの設定

その他おまけ等

その他の改造例

その他メール全般のお薦めテク

参考

これもおすすめ

Outlook

Excel

マクロソース

2 thoughts on “【仕事で残念な人にならないために】Outlookメール誤送信チェックマクロ【冷汗防止】”

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

概要

用途

機能

［補足］マクロ登録先について

FAQ

［補足］セキュリティオプションの設定

その他おまけ等

その他の改造例

その他メール全般のお薦めテク

参考

これもおすすめ icon-thumbs-o-up

Outlook

Excel

マクロソース

Related posts:

2 thoughts on “【仕事で残念な人にならないために】Outlookメール誤送信チェックマクロ【冷汗防止】”

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

これもおすすめ

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