patagonの日記： [コンピュータ,ネット]Outlookでメール送信時に件名・添付ファイルの漏れ、宛先をチェック。1分後にメッセージ送信 4
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
「SMTPサーバの記述箇所」について (スコア:0)
Re:「SMTPサーバの記述箇所」について (スコア:1)
以下のメッセージを表示しました。
Microsoft Visual Basic
実行時エラー'438'
オブジェクトは、このプロパティまたはメソッドをサポートしていません。
デバッグしてみると以下の行を指していました。
Re: (スコア:0)
Re:「SMTPサーバの記述箇所」について (スコア:1)
どうもありがとうございます。
機会があれば試してみます。
偶然かどうか不明ですが、今では件のページ、(このマクロは Outlook 2007 専用です。) と修正してあります。
しかし日付は2007年4月14日のままで、さらに修正したとも何も書いてません。
こういう修正の仕方をする方なんですね。
残念です。