©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の起動時にダイアログが表示されるようになるので、「マクロを有効にする」をクリックして起動します。

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

その他おまけ等

その他の改造例

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

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

• メール全体対象の送受信ボタンは右端において、個別メールごとに行う返信や送信ボタンは左に置くようレイアウトする。→誤クリックをかなり防止します。（致命的なものは、意識して操作させるように若干使いにくくさせる）
• 新規作成などメール作成ウィンドウでをメール送信しても、直ちに送信しないよう（設定ができるのであれば）設定する。送信フォルダに格納されるだけ。 送信フォルダ格納後、メールビューウィンドウの送受信ボタンで送信する（昼休み前や帰り際に忘れずに！）。

参考

• Outlookマクロ：fromアドレスと件名の確認、常にBCC | hm-lab
• Outlook VBA Tips - おためしwiki
• ◆Outlook VBA（メール誤送信防止のためのチェックあれこれ その２）: 好きなものあれこれ

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

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

Outlook

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

Excel

• 【仕事効率技】Excelが便利になるVBA マクロライブラリ集 とってもExcel
• Excelが便利に楽になるちょいわざ 20+α とってもExcel

マクロソース

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

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

ユーザ定義がないと RegExpのところで警告が出たら。。。 RegExp（正規表現）を表示のため使っているので以下の設定をしてください。 VBA Editor のツール(T) -> 参照設定(R) から "Microsoft VBScript Regular Expressions 5.5 ”. をチェック

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

関連ページリンク

Check

Pocket

Tweet