返信メッセージで表示名をアドレス帳のものに置き換え、さらに差出人以外は Cc に移動するマクロ


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


『メーリングリストのメールの差出人に返信し、ほかの受信者を Cc に指定するマクロ』と、同じ要望ですが、メール送信者が宛先に複数いれた状態でReplyWithAddressBookNameで返信すると送信者だけでなく、送られてきた宛名全員が送信先になってしまいます。

For Each objRec In objReply.Recipients
objRec.Type = olCC
Next
の部分を活用して元々の宛名をCCに入れたいと試行錯誤しておりますが、送信者までCCに入ってしまいます。

ReplyWithAddressBookNameのマクロで対応は可能でしょうか。
アドバイス頂けますか。


あらかじめ送信者のアドレスを取得しておき、受信者のアドレスがそれと一致した場合のみ Type に olTo を、それ以外は olCC を設定するという方法で可能です。
具体的なマクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。
'
Public Sub ReplyWithAddressBookNameCc()
    Const PR_SMTP_ADDRESS = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
    Dim strSenderAddress As String
    Dim objReply As MailItem
    Dim objRecip As Recipient
    Dim objContact As ContactItem
    Dim objAddrList As AddressList
    Dim i As Integer
    Dim objAddrEntry As AddressEntry
    Dim bFound As Boolean
    Dim cRecips As Integer
    Dim colAddress() As String
    Dim colName() As String
    Dim colType() As Integer
    '
    strSenderAddress = ActiveInspector.CurrentItem.SenderEmailAddress
    Set objReply = ActiveInspector.CurrentItem.ReplyAll
    cRecips = objReply.Recipients.Count
    ReDim colAddress(cRecips) As String
    ReDim colName(cRecips) As String
    ReDim colType(cRecips) As Integer
    For i = cRecips To 1 Step -1
        Set objRecip = objReply.Recipients.Item(i)
        With objRecip.AddressEntry
            If .Type = "SMTP" Then
                colAddress(i) = objRecip.Address
            Else
                colAddress(i) = .PropertyAccessor.GetProperty(PR_SMTP_ADDRESS)
            End If
        End With
        colName(i) = objRecip.Name
        If objRecip.Address = strSenderAddress Then
            colType(i) = olTo
        Else
            colType(i) = olCC
        End If
        objReply.Recipients.Remove i
    Next
    '
    For i = 1 To cRecips
        Set objRecip = Nothing
        For Each objAddrList In Session.AddressLists
            If objAddrList.AddressListType = olOutlookAddressList Then
                For Each objAddrEntry In objAddrList.AddressEntries
                    If objAddrEntry.Address = colAddress(i) Then
                        Set objRecip = objReply.Recipients.Add(colAddress(i))
                        Set objRecip.AddressEntry = objAddrEntry
                        objRecip.Type = colType(i)
                        Exit For
                    End If
                Next
                If Not objRecip Is Nothing Then
                    Exit For
                End If
            End If
        Next
        If objRecip Is Nothing Then
            Set objRecip = objReply.Recipients.Add(colName(i) & "<" & colAddress(i) & ">")
            objRecip.Type = colType(i)
        End If
    Next
    objReply.Display
End Sub

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

広告

コメントを残す

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

WordPress.com ロゴ

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

Twitter 画像

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

Facebook の写真

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

Google+ フォト

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

%s と連携中