メールの宛先に指定したアドレスを連絡先の名前に置き換えるマクロ


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


はじめまして。
いつもサイトを拝見させていただき、大変お世話になっております。
Outlook2013で連絡先の閲覧ウインドウで、名前の下にある4つのアイコンの中から一番右のメールのアイコンからメールを作成しようとすると、宛先にはメールアドレスが表示されます。この時にメールアドレスでなく、連絡先に登録してある表示名を宛先に表示する設定とかあるのでしょうか。新しい電子メールから作成した時と、送信済みアイテムの宛先が異なる名前で残ってしまうのが困っています。
宜しくお願い致します。


残念ながら閲覧ウィンドウのボタンで宛先に表示名を付けて追加する設定はありませんが、宛先がアドレスとなっている状態で以下のマクロを実行することでアドレス帳の名前に置き換えることができます。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub ResolveWithContacts()
    Dim objMail 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
    Dim strEntryID As String
    '
    Set objMail = ActiveInspector.CurrentItem
    objMail.Save
    objMail.Recipients.ResolveAll
    cRecips = objMail.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 = objMail.Recipients.Item(i)
        colAddress(i) = objRecip.Address
        colName(i) = objRecip.Name
        colType(i) = objRecip.Type
        objMail.Recipients.Remove i
    Next
    '
    For i = 1 To cRecips
        bFound = False
        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 = objMail.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
            If colName(i) <> colAddress(i) Then
                Set objRecip = objMail.Recipients.Add(colName(i) & " <" & colAddress(i) & ">")
            Else
                Set objRecip = objMail.Recipients.Add(colAddress(i))
            End If
            objRecip.Type = colType(i)
            objRecip.Resolve
        End If
    Next
    objMail.Close olSave
    objMail.Display
End Sub

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

広告

コメントを残す

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

WordPress.com ロゴ

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

Twitter 画像

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

Facebook の写真

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

Google+ フォト

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

%s と連携中