Outlookでメール送信時に件名・添付ファイルの漏れ、宛先をチェック。1分後にメッセージ送信。

Outlook宛先確認アドイン ver2.0.1はExchangeサーバをグループウェアとして使う場合(例えば自社内のメールや予定表)に用いられるプロトコル X.400に対応していないので使うのを諦めた。(実際に使用された方のコメントを頂けると嬉しいです)と書いてあったので、作者にも希望として連絡はした。他に自分の環境では動作がおかしかったこともあり、使用を中止した。詳細は2008年10月04日の日記を参照。

そこで一度は検討して実行しなかったVBAを使うこととした。
環境はサーバ Microsoft Exchange Server 2003(Version. 6.5)、クライアント側プログラム Microsoft Outlook 2003。

マクロの登録はOutlook ツール - マクロ Visual Basic Editor起動。プロジェクトエクスプローラでThisOutlookSessionを表示させ、コードとして貼り付ける

チェック時の警告メッセージ
件名漏れ
添付ファイル漏れ
宛先チェック(自ドメイン外への送信)

簡単なほうから。「1分後にメッセージ送信」は＠IT：Windows TIPS -- Tips：Outlook 2003のメッセージ送信を1分間遅延させるの通り。もちろん遅延時間は2分、3分…と任意に設定可能。メール送信すると、一旦、メールが送信トレイに入り、設定時間後に送信され、送信済みトレイに移る。メールだけでなくミーティングなんかのスケジュール共有のメールも1分後に送信になるけど。すぐには送信しないので「やっぱりやめた。文字に誤りがあったので修正したい」という時に助かる。

メール送信時に件名・添付ファイルの漏れ、宛先をチェックは以下を参考とした。
Outlook 研究所: メールの送信前にチェックするの「空白の件名をチェックするマクロ」、「メールの宛先を送信前に確認するマクロ」
Outlook でメール送信時に件名や添付ファイルのチェックを行う方法 - アジャイルプログラマの日常

しかしOutlook 研究所の方はSMTPサーバの記述箇所に漏れ・誤りがある(*)。参考になったのはOutlook(2003)のマクロ紹介 「1)Microsoft Outlook 2003用マクロ:情報セキュリティー用(説明)」の箇所。
*:ブログ開設者(Millefeuille氏)に連絡しようと試みるが、メールを送ろうにも、掲示板に書き込もうにもWindows Live IDを作ってからじゃないと出来ないと警告される。連絡方法がない、残念。諦めた。

また添付のチェックは題やメール本文に「添付します」、「別添」という文字を含んだ場合にチェックすることにした。「添付」だけでもチェックする場合は、検索文字列を変更すること。チェックの結果、ヒットした時にデフォルトをCancelとした(+ vbDefaultButton2)。デフォルトをOKとする場合は、ここを削除すること。

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
 
    Dim strSubject As String
    Dim strBody As String
 
    strSubject = Item.Subject '件名
    strBody = Item.Body       '本文
 
    ' 件名チェック
    If Item.Subject = "" Then
        If MsgBox("このメッセージには件名がありません。[OK] をクリックすると送信します。", vbOKCancel + vbExclamation + vbDefaultButton2) = vbCancel Then
           Cancel = True
        End If
    End If
 
    ' 添付ファイルチェック
    If (InStr(strSubject & strBody, "添付します") > 0 Or InStr(strSubject & strBody, "別添") > 0) And Item.Attachments.Count = 0 Then
        If MsgBox("添付ファイルを忘れている可能性があります。[OK] をクリックすると送信します。", vbOKCancel + vbQuestion + vbDefaultButton2) = vbCancel Then
            Cancel = True
            Exit Sub
        End If
    End If
 
    ' 社外チェック
    Const MyDomain = "@sample.org" ' 社内扱いするドメインを指定します。
    Dim i As Integer
    Dim strAddress As String
    Dim strExtAddr As String
    Dim strPrompt As String
 
    strExtAddr = ""
    For i = 1 To Item.Recipients.Count
        With Item.Recipients.Item(i)
            strAddress = .Address
            If LCase(strAddress) Like "/o=*" Then
                ' アドレスが Exchange アドレスなら、SMTP アドレスを取得
                ' strAddress = .PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x39FE001E") '
                ' ↓ 社外メールアドレスが複数あるとNGなので結局コメントアウト
                ' strAddress = .PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x39FE001E") = "server-smtp.sample.org"
                GoTo nextloop ' 結局挿入
            End If
            If Not strAddress Like "*" & MyDomain Then
                strExtAddr = strExtAddr & strAddress & ";"
            End If
nextloop: ' 結局挿入
        End With
    Next
 
    If strExtAddr <> "" Then
        strPrompt = "このメッセージには以下の社外アドレスが含まれています。[OK] をクリックすると送信します。" & vbLf & strExtAddr
        If MsgBox(strPrompt, vbOKCancel + vbExclamation + vbDefaultButton2) = vbCancel Then
            Cancel = True
        End If
    End If
 
End Sub