メール送信の際に本文のリンク文字列の前後に <> がついていない場合に警告を表示するマクロ

outlooklab Outlook 2010 マクロ、Outlook 2013 マクロ、Outlook 2016 マクロ

コメントにて以下のご要望をいただきました。

困ったときにはいつも参照させて頂いております。

早速ですが，メール本文にリンクアドレスを挿入する場合，山括弧”<>”で囲むことでリンク途切れを防ぐことが出来ます。このことを皆さんに周知するのですが，未だ山括弧を付けずに送信される方が後を絶ちません。

メール送信時にリンクアドレスが山括弧で囲まれていないとアラートを出すような仕組みは作れないでしょうか？

よろしくお願い致します。

メール送信時に何らかの処理を行う場合は Application の ItemSend イベントを使用します。
HTML 形式やリッチテキスト形式の場合は <> で囲まなくてもリンク切れせずに正しくリンクを挿入することができますので、本文がテキスト形式の場合だけ本文をチェックすればよいでしょう。
本文形式は MailItem オブジェクトの BodyFormat プロパティで確認ができます。
リンクが <> で囲まれているかどうかは本文が格納されている Body プロパティについてリンク文字列の先頭である http:// や https:// を InStr 関数により検索し、見つかった位置の一つ前に < があるかという点と、その後の文字列で > があるかという点を確認します。
<> で囲っていないリンクが見つかったら、警告を表示しますが、その際に [はい] を選択すると送信をキャンセルするようにします。
これは、何かダイアログが出ても読まずに [はい] をクリックするような習慣がついている場合に、警告が無意味にならないようにするためです。
まとめると以下のようなマクロになります。

' ここをトリプルクリックでマクロ全体を選択できます。
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
     ' メール以外はチェックしない
     If TypeName(Item) <> "MailItem" Then
         Exit Sub
     End If
     ' テキスト形式のメールのみチェック
     If Item.BodyFormat <> olFormatPlain Then
         Exit Sub
     End If
     ' http, https, file で始まる URL をチェック
     If FindBareURL(Item.Body, "http") Or _
        FindBareURL(Item.Body, "https") Or _
        FindBareURL(Item.Body, "file") Then
         If MsgBox("<> で囲っていない URL があります。メールの編集に戻りますか?", vbYesNo) = vbYes Then
             Cancel = True
         End If
     End If
End Sub
' <> で囲っていない URL の検索
Private Function FindBareURL(strBody As String, strSchema As String)
     Dim iUrl As Integer
     ' 本文のスキャンが完了しない場合は <> で囲っていない URL がある
     FindBareURL = True
     ' URL の文字列を検索
     iUrl = InStr(strBody, strSchema & "://")
     While iUrl > 0
         ' 本文の最初に URL がある
         If iUrl = 1 Then
             Exit Function
         End If
         ' URL の直前に < がない
         If Mid(strBody, iUrl - 1, 1) <> "<" Then
             Exit Function
         End If
         ' URL の終わりの > を検索
         While Mid(strBody, iUrl, 1) <> ">"
             ' > より先に改行がある
             If Mid(strBody, iUrl, 1) = vbLf Then
                 Exit Function
             End If
             iUrl = iUrl + 1
             ' > が見つからずに本文の終わりに到達
             If iUrl > Len(strBody) Then
                 Exit Function
             End If
         Wend
         ' 次の URL を検索
         iUrl = InStr(iUrl + 1, strBody, strSchema & "://")
     Wend
     ' 最後まで問題がなかったら OK
     FindBareURL = False
End Function

マクロの登録方法やメニューへの追加について

コメントを残す