複数の連絡先フォルダーから連絡先を検索し、メールの先頭に受信者の名前を追加するマクロ HTML メール対応版


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


マクロAddHeader2を重宝させていただいております。細かいことですが、メール本文に鵜入される文字のフォントとフォントサイズをはじめインデントの設定などが送信メールの既定の設定と異なる設定で挿入されてしまいます。既定の設定で文字を挿入する方法はありますでしょうか。フォントやフォントサイズについては、受信側には何も影響がありませんが,インデントの値については受信側のメール送受信ソフトの表示も変ってしまうことがわかりました。是非とも既定の設定を変えずに文字を挿入する方法を教えていただきたく思います。


AddHeader2 は本文としてはテキスト形式が使われるという前提で作成していました。
最近はHTML形式のメールも抵抗なく使われるようになってきているようですので、AddHeader2 を HTML 形式でもフォーマットを崩すことなく使えるように修正してみました。
コードは以下の通りです。送信メールを表示して AddHeader3 を実行してください。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub AddHeader3()
    Dim objMail As MailItem
    Dim objContact As ContactItem
    Dim objContacts As Folder
    Dim i As Integer
    Dim strName As String
    Dim objBody 'As Word.Document
'
    Set objMail = ActiveInspector.CurrentItem
    Set objBody = ActiveInspector.WordEditor
    Set objContacts = Application.Session.GetDefaultFolder(olFolderContacts)
    For i = objMail.Recipients.Count To 1 Step -1
        strName = ""
        With objMail.Recipients.Item(i)
            If .Type = olTo Then
                Set objContact = FindContactByAddressInAFolder(.Address, objContacts)
                If Not objContact Is Nothing Then
                    strName = objContact.LastFirstAndSuffix
                Else
                    Set objContact = FindContactByAddressInAFolder(.Address, objContacts.Folders("連絡先(会社)"))
                    If Not objContact Is Nothing Then
                        strName = objContact.Department & vbCrLf & "  " & objContact.LastFirstSpaceOnly & " " & objContact.JobTitle
                    Else
                        Set objContact = FindContactByAddressInAFolder(.Address, objContacts.Folders("連絡先(顧客)"))
                        If Not objContact Is Nothing Then
                            strName = objContact.CompanyName & vbCrLf & "  " & objContact.LastFirstAndSuffix
                        End If
                    End If
                End If
            End If
        End With
        If strName <> "" Then
            objBody.Application.Selection.HomeKey 6 ' wdStory
            objBody.Application.Selection.TypeText strName & vbCrLf
        End If
    Next
End Sub
'
Private Function FindContactByAddressInAFolder(strAddress As String, objContacts)
    Dim objContact As ContactItem
    '
    Set objContact = objContacts.Items.Find("[Email1Address] = '" & strAddress _
        & "' or [Email2Address] = '" & strAddress _
        & "' or [Email3Address] = '" & strAddress & "'")
    Set FindContactByAddressInAFolder = objContact
End Function

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

広告

コメントを残す

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

WordPress.com ロゴ

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

Twitter 画像

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

Facebook の写真

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

Google+ フォト

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

%s と連携中