連絡先をマクロで活用する

Outlook の連絡先はアドレス帳として使うことができますが、VBA マクロを使うことでもっと活用することもできます。今回は 2 つの活用法を紹介します。

0. メールアドレスから連絡先を検索する

活用法を紹介する前に、メールアドレスから連絡先を検索するマクロを紹介しておきます。以下の FindContactByAddress 関数は、strAddress で指定されたアドレスにより連絡先を検索し、見つかったエントリの ContactItem オブジェクトを返します。以降で紹介するマクロでも使用しますので、こちらは必ず定義しておいてください。

Private Function FindContactByAddress(strAddress As String)
    Dim objContacts 'As Folder
    Dim objContact As ContactItem
    '
    Set objContacts = Application.Session.GetDefaultFolder(olFolderContacts)
    Set objContact = objContacts.Items.Find("[Email1Address] = '" & strAddress _
        & "' or [Email2Address] = '" & strAddress _
        & "' or [Email3Address] = '" & strAddress & "'")
    Set FindContactByAddress = objContact
End Function

1. あて先に指定したアドレスの名前を本文に追加する

仕事でメールを送信する際などには、本文に「○○様」というように受信者の名前を追加して送信する場合があります。このとき、せっかく連絡先から選択しているのですから、連絡先の表示名や敬称が使われないというのはもったいない話です。そんなわけで、メールの To に指定されているアドレスを連絡先から検索し、その表示名+敬称を本文の先頭に追記するというマクロを作りました。以下の AddHeader を呼び出すことで、本文に宛先の名前が追加されます。

Public Sub AddHeader()
    Dim objMail As MailItem
    Dim objContact As ContactItem
    Dim i As Integer
'
    Set objMail = Application.ActiveInspector.CurrentItem
    For i = 1 To objMail.Recipients.Count
        With objMail.Recipients.Item(i)
            If .Type = olTo Then
                Set objContact = FindContactByAddress(.Address)
                If Not objContact Is Nothing Then
                    objMail.Body = objContact.LastFirstAndSuffix & vbCrLf & objMail.Body
                End If
            End If
        End With
    Next
End Sub

2. 受信したメールの差出人を連絡先から検索する

携帯電話などから送信されてきたメールでは、差出人の表示名が設定されていないため、誰から送信されてきたものなのか分からない場合があります。連絡先に登録されているアドレスから自動的に検索されたら便利だと思いませんか? 以下は、受信したメールの差出人のアドレスを連絡先で検索し、見つかった場合に差出人名を置き換えるというマクロです。受信した際に処理を行うため、以前紹介した NewMailEx イベントを使っています。なお、本来は From で指定されている表示名そのものを置き換えたいところですが、Outlook のオブジェクト モデルではこのプロパティが読み取り専用となっているため、代理送信などで使われる SentOnBehalfOfName プロパティによって表示名を設定しています。この場合、メッセージ一覧の差出人は連絡先の表示名で置き換えられますが、実際にそのアイテムを開くと差出人はもともとの差出人名が表示されます。
なお、受信トレイの差出人の名前を置き換える場合は、RewriteSenderInInbox を実行してください。

' メール受信時に発生するイベント
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    Dim i As Integer
    Dim c As Integer
    Dim colID As Variant
    If Instr(EntryIDCollection, ",") = 0 Then
        RewriteSender EntryIDCollection
    Else
        colID = Split(EntryIDCollection, ",")
        For i = LBound(colID) To UBound(colID)
            RewriteSender colID(i)
        Next
    End If
End Sub
'
' 差出人の名前を置き換えるサブプロシージャ
Private Sub RewriteSender(ByVal strEntryID As String)
    On Error Resume Next
    Dim objMail 'As MailItem
    Dim objContact As ContactItem
    Dim strSenderAddress As String
    '
    Set objMail = Application.Session.GetItemFromID(strEntryID)
    If objMail.MessageClass = "IPM.Note" Then
        strSenderAddress = objMail.SenderEmailAddress
        Set objContact = FindContactByAddress(strSenderAddress)
        If Not objContact Is Nothing Then
            objMail.SentOnBehalfOfName = objContact.FileAs
            objMail.Save
        End If
    End If
End Sub
'
' 受信トレイの差出人の名前を置き換えるサブプロシージャ
Public Sub RewriteSenderInInbox()
    On Error Resume Next
    Dim objMail 'As MailItem
    '
    For Each objMail In Application.Session.GetDefaultFolder(olFolderInbox).Items
        RewriteSender objMail.EntryID
    Next
End Sub
' この下に、上記の FindContactByAddress を追加

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

2011/02/02: 受信トレイの差出人の名前を置き換えるプロシージャを追加しました。