パブリックフォルダーの連絡先をマクロで活用する


連絡先をマクロで活用する」という記事のコメントで、検索をする連絡先をパブリック フォルダー上の連絡先とそのサブフォルダーにしたいというご要望をいただきました。

特定のフォルダーとそのフォルダーについて検索処理などを順次行う必要がある場合、再帰という手法を使用します。

たとえば、「連絡先をマクロで活用する」のマクロを、パブリック フォルダーの連絡先以下のサブフォルダーまで検索するように変更したマクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。
'
' メール受信時に発生するイベント
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
'
' PF 連絡先を検索する関数
Private Function FindContactByAddress(strAddress As String)
    Dim objContacts As Folder
    Dim objContact As ContactItem
    '
    Set objContacts = Application.Session.Folders("パブリック フォルダ").Folders("すべてのパブリック フォルダ").Folders("連絡先")
    ' Outlook 2010 は下記を使用、sample@example.com を自分のメールアドレスに置き換える
    'Set objContacts = Application.Session.Folders("パブリック フォルダー - sample@example.com").Folders("すべてのパブリック フォルダー").Folders("連絡先")
    Set FindContactByAddress = FindContactRecursive(objContacts, strAddress)
End Function
'
' 連絡先フォルダーを再帰的に検索する関数
Private Function FindContactRecursive(objContacts As Folder, strAddress As String)
    Dim objSubFolder As Folder
    Set objContact = objContacts.Items.Find("[Email1Address] = '" & strAddress _
        & "' or [Email2Address] = '" & strAddress _
        & "' or [Email3Address] = '" & strAddress & "'")
    ' 見つからなければサブフォルダーを検索
    If objContact Is Nothing Then
        For Each objSubFolder In objContacts.Folders
            ' 再帰的に検索
            Set objContact = FindContactRecursive(objSubFolder, strAddress)
            If Not objContact Is Nothing Then
                ' 見つかったら検索終了
                Set FindContactRecursive = objContact
                Exit Function
            End If
        Next
    End If
    Set FindContactRecursive = objContact
End Function

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

広告

コメントを残す

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

WordPress.com ロゴ

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

Twitter 画像

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

Facebook の写真

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

Google+ フォト

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

%s と連携中