連絡先の情報をもとに古いアドレスを置き換えて返信するマクロ

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

---

会社のメールアドレスが変更になりました。過去に受信したメールに対して全員返信を行うときにtoやccにある旧メールアドレスを新メールアドレスに変更できないかと考えています。
アドレス帳には新旧両方のメールアドレスを登録しました。
「返信メッセージで表示名を連絡先のものに置き換えるマクロ (Exchange 対応版) 」を流用して作れないでしょうか？

objAddrEntry.Addressでメールアドレスを検索して一致したobjAddrEntryに含まれる2つ目のアドレスに変更することを考えたのですが、
objAddrEntryにはアドレスが1つしかありませんでした
複数のアドレスを取得するにはどのようにすればよいのでしょうか
アドバイスをいただきたくお願いします。

---

連絡先アイテムには複数のメールアドレスを設定できますが、これを Outlook アドレス帳で見ると、それぞれのアドレスが独立したエントリーとして扱われます。
そのため、AddressEntry オブジェクトから同じアイテムの別のアドレスを取得するということはできません。
連絡先の情報をもとに古いアドレスを置き換えるなら、古いアドレスで連絡先フォルダーを検索し、見つかったエントリの 2 番目のアドレスを取得するという動作が必要になります。

以下のマクロは特定のドメインのアドレスについて連絡先フォルダーを検索し、見つかったアイテムの [電子メール 2] のアドレスに置き換えるというものです。
ドメインを限定しているのは、自社以外の連絡先で複数のアドレスが登録されていた場合にまで置き換わると問題かと思ったためです。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub ReplyWithNewAddress()
    Const OLD_DOMAIN = "@example.com" ' 置き換える古いドメイン名
    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
    '
    If TypeName(Application.ActiveWindow) = "Inspector" Then
        Set objReply = ActiveInspector.CurrentItem.ReplyAll
    Else
        Set objReply = ActiveExplorer.Selection(1).ReplyAll
    End If
    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)
        colAddress(i) = objRecip.Address
        colName(i) = objRecip.Name
        If objRecip.Address Like "*" & OLD_DOMAIN Then
            FindNewAddress colAddress(i), colName(i)
        End If
        colType(i) = objRecip.Type
        objReply.Recipients.Remove i
    Next
    '
    For i = 1 To cRecips
        If colName(i) <> colAddress(i) Then
            Set objRecip = objReply.Recipients.Add(colName(i) & "<" & colAddress(i) & ">")
        Else
            Set objRecip = objReply.Recipients.Add(colAddress(i))
        End If
        objRecip.Type = colType(i)
    Next
    objReply.Recipients.ResolveAll
    objReply.Display
End Sub
'
Private Sub FindNewAddress(strAddress As String, strName As String)
    Dim objContacts 'As Folder
    Dim objContact As ContactItem
    '
    Set objContacts = Application.Session.GetDefaultFolder(olFolderContacts)
    Set objContact = objContacts.Items.Find("[Email1Address] = '" & strAddress & "'")
    If Not objContact Is Nothing Then
        strAddress = objContact.Email2Address
        strName = Replace(objContact.Email2DisplayName, "(" & strAddress & ")", "")
    End If
End Sub


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