複数の受信者に送信する際に警告を表示するマクロ


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


outlook2007で、以下のようなことがVBAでできますでしょうか?
①複数の宛先(To,CC,BCC)に送信する時だけ送信しても大丈夫かどうかの警告メッセージを表示したい。
②警告メッセージは、To:aaaa CC:bbbb BCC:CCCC と別々に表示されるようにしたい。
外部ドメインかどうかは関係なく、とにかく複数の宛先がある場合に表示させるようにしたいのですが、
可能でしょうか?


以下のようなマクロで可能です。
ただ、宛先に多数のユーザーが指定されているような場合に、警告メッセージが画面からはみ出すというような状態になるかもしれません。
そのようなことを考慮するとアドレスをスクロールバー付きで表示できるようなダイアログを作ったりする必要があり、そのようなことも VBA なら不可能ではありませんが、そうなるともはやマクロの範疇を超えてくるようにも思います。

' ここをトリプルクリックでマクロ全体を選択できます。
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    WarnMultipleRecipients Item, Cancel
End Sub
'
Private Sub WarnMultipleRecipients(ByVal Item As Object, Cancel As Boolean)
    On Error Resume Next
    Dim oRec As Recipient
    Dim strTo As String
    Dim strCc As String
    Dim strBcc As String
    Dim strMsg As String
    ' 受信者が一人なら何もしない
    If Item.Recipients.Count = 1 Then
        Exit Sub
    End If
    ' 受信者確認
    For Each oRec In Item.Recipients
        Select Case oRec.Type
            Case olTo
                strTo = strTo & GetNameAddr(oRec)
            Case olCC
                strCc = strCc & GetNameAddr(oRec)
            Case olBCC
                strBcc = strBcc & GetNameAddr(oRec)
        End Select
    Next
    ' 確認ダイアログの表示
    strMsg = "下記の複数のアドレスに送信します。よろしいですか?" & vbCrLf
    If strTo <> "" Then
        strMsg = strMsg & "宛先: " & strTo & vbCrLf
    End If
    If strCc <> "" Then
        strMsg = strMsg & "Cc: " & strCc & vbCrLf
    End If
    If strBcc <> "" Then
        strMsg = strMsg & "Bcc: " & strBcc & vbCrLf
    End If
    If MsgBox(strMsg, vbYesNo, "宛先確認") = vbNo Then
        Cancel = True
    End If
End Sub
'
Private Function GetNameAddr(oRec As Recipient)
    Const PR_ORIGINAL_DISPLAY_NAME = "http://schemas.microsoft.com/mapi/proptag/0x3a13001e"
    Const PR_SMTP_ADDRESS = "http://schemas.microsoft.com/mapi/proptag/0x39fe001e"
    Dim strAddress As String
    If oRec.AddressEntry.Type = "SMTP" Then
        strAddress = oRec.Address
    Else ' Exchange 対応
        If oRec.AddressEntry.AddressEntryUserType = olOutlookContactAddressEntry Then
            strAddress = oRec.AddressEntry.PropertyAccessor.GetProperty(PR_ORIGINAL_DISPLAY_NAME)
        Else
            strAddress = oRec.AddressEntry.PropertyAccessor.GetProperty(PR_SMTP_ADDRESS)
        End If
    End If
    ' 表示名に SMTP アドレスが含まれている場合はアドレスはつけない
    If InStr(oRec.Name, strAddress) > 0 Then
        GetNameAddr = oRec.Name & "; "
    Else
        GetNameAddr = oRec.Name & "<" & strAddress & ">" & "; "
    End If
End Function

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

複数の受信者に送信する際に警告を表示するマクロ」への1件のフィードバック

コメントを残す

以下に詳細を記入するか、アイコンをクリックしてログインしてください。

WordPress.com ロゴ

WordPress.com アカウントを使ってコメントしています。 ログアウト / 変更 )

Twitter 画像

Twitter アカウントを使ってコメントしています。 ログアウト / 変更 )

Facebook の写真

Facebook アカウントを使ってコメントしています。 ログアウト / 変更 )

Google+ フォト

Google+ アカウントを使ってコメントしています。 ログアウト / 変更 )

%s と連携中