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


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: 受信トレイの差出人の名前を置き換えるプロシージャを追加しました。

広告

連絡先をマクロで活用する」への69件のフィードバック

  1. VBマクロ超初心者@豊田と申します。
     
    上記のマクロを登録し、「Outlook VBA マクロ、はじめの一歩」の記載のように、クイックアクセスツールバーを追加しようとしたのですが
    登録したはずのマクロが表示されず、うまくいきません。その他のマクロ実行の手順でもすべて同様です。
    どのように実行すれば良いか教えてください。
     
    なお、環境はOUTLOOK 2007です。
     
     
     

  2. すみません。マクロに間違いがありました。
    Private Sub AddHeader() ではなく、Public Sub AddHeader() でした。
    本文のマクロも訂正しました。

  3. VBマクロ超初心者@豊田です。
     
    早速回答ありがとうございました。
    大変便利なので欲が出てきたので、試行錯誤で機能拡張してみましたが
    うまくいかない点がありますので、ご存知でしたらばお知恵を貸してください。
    いくつか質問があるので、小分けにして記載させていただきます。
     
    【機能拡張-1】
    ・個人用連絡先の”連絡先”以外のフォルダ(カテゴリ?)も検索する。
     
    【ソース-1】
    \’メールアドレスから連絡先を検索する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 & "\’")            \’07/06/14 by toyoda 連絡先以外もチェックするよう修正 START    If objContact Is Nothing Then        For i = 1 To objContacts.Folders.Count            Set objContact = objContacts.Folders.Item(i).Items.Find("[Email1Address] = \’" & strAddress _                             & "\’ or [Email2Address] = \’" & strAddress _                             & "\’ or [Email3Address] = \’" & strAddress & "\’")            If Not objContact Is Nothing Then                Exit For            End If        Next    End If    \’07/06/14 by toyoda 連絡先以外もチェックするよう修正 END        Set FindContactByAddress = objContactEnd Function
     
    【不明点-1】

      objContacts の構造を除いていたら連絡先以外の情報がobjContacts.Foldersに格納されていそうだったのでそこを参照しています。
      しかし、私の環境では、連絡先以外のフォルダが17あるのですが、objContacts.Folders.Count は11 が格納されており、全フォルダ
      を参照してくれません。
        参照する内容や方法に誤りがあるのでしょうか?
     

  4. VBマクロ超初心者@豊田です。
     
    【機能拡張-2】
    ・Cc も対象とする。
    ・Ccの場合には直前に識別文字(固定で”写)”を表示する。
     ⇒ このため、メールアドレスチェックを後方からに変更した。 
    ・参照文字列をEmail1DisplayName を使用(個人的な連絡先の管理の都合上)
     
    【ソース-2】
    \’あて先に指定したアドレスの名前を本文に追加するPublic Sub AddHeader()    Dim objMail As MailItem    Dim objContact As ContactItem    Dim i As Integer    Dim cc_flag As Boolean        \’07/06/14 by toyoda    Const CC_STR = "写)"        cc_flag = False               \’07/06/14 by toyoda        Set objMail = Application.ActiveInspector.CurrentItem    For i = objMail.Recipients.Count To 1 Step -1        With objMail.Recipients.Item(i)\’            If .Type = olTo Then                                                           \’07/06/14 by toyoda            If (.Type = olTo) Or (.Type = olCC) Then                                        \’07/06/14 by toyoda                Set objContact = FindContactByAddress(.Address)                If Not objContact Is Nothing Then                    If (.Type = olCC) And (cc_flag = False) Then                            \’07/06/14 by toyoda                        cc_flag = True                                                      \’07/06/14 by toyoda                    End If                                                                  \’07/06/14 by toyoda                    If (.Type = olTo) And (cc_flag = True) Then                             \’07/06/14 by toyoda                        objMail.Body = Email1DisplayName & vbCrLf & CC_STR & objMail.Body   \’07/06/14 by toyoda                        cc_flag = Flase                                                     \’07/06/14 by toyoda                    Else                                                                    \’07/06/14 by toyoda                        objMail.Body = objContact.Email1DisplayName & vbCrLf & objMail.Body \’07/06/14 by toyoda                    End If                                                                  \’07/06/14 by toyoda                Else                                                                        \’07/06/14 by toyoda                        objMail.Body = .Address & vbCrLf & objMail.Body                     \’07/06/14 by toyoda                End If            End If        End With    NextEnd Sub
     
    【不明点-2】

      CC_STR のような個人ごとにカスタマイズしたい情報をソースから追い出し、設定情報とするには
      どのような方法があるのでしょうか?
     

  5. VBマクロ超初心者@豊田です。
     
    【機能拡張-3】
    ・差出人の名前を置き換えを受信時だけでなく、メールアイテムを選択して実施する。
     ⇒ 既に受信したメールも変換したかったので作ってみました。
     
    【ソース-3】
    \’ 差出人の名前を置き換えるサブプロシージャPublic Sub SelectedItems_RewriteSender()    Dim myOlApp As New Outlook.Application    Dim myOlExp As Outlook.Explorer    Dim myOlSel As Outlook.Selection    Dim i As Integer        Set myOlExp = myOlApp.ActiveExplorer    Set myOlSel = myOlExp.Selection    For i = 1 To myOlSel.Count        RewriteSender myOlSel.Item(i).EntryID    Next i
    End Sub
     
    【不明点-3】

      直接上のソースの質問ではなく、差出人の名前を置き換えるサブプロシージャ(RewriteSender)についての質問です。
      メーリングリストなどを使って送信されたメールの場合、SenderEmailAddress の内容は送信者ではなくメーリングリストのアドレス
      が格納されてします。これを、実際の送信者(From)のアドレスで連絡先の検索を行いたいのですが、MailItem オブジェクトの構造
      を眺めているのですが、From 情報が見当たりません。どこをどのように参照すればよいでしょうか?
     

  6. 豊田

    VBマクロ超初心者@豊田です。
     
    【機能拡張-4】
     ・ ”全員へ返信”や”返信”を行った場合、自動的にあて先を本文に設定する。
    【不明点-4】
    ・どのようにすれば実現できるか教えてください。MailItem.Reply イベントトリガーとして実行させるものと予想しているのですが
    実装方法が分かっていません。

  7. コメントだとスレッドにならないので、まとめてレスします。
    >【不明点-1】>  objContacts の構造を除いていたら連絡先以外の情報がobjContacts.Foldersに格納されていそうだったのでそこを参照しています。>  しかし、私の環境では、連絡先以外のフォルダが17あるのですが、objContacts.Folders.Count は11 が格納されており、全フォルダ>  を参照してくれません。>    参照する内容や方法に誤りがあるのでしょうか?
    objContacts.Folders に含まれるフォルダは、[連絡先] の直下にあるフォルダのみです。孫フォルダやほかのフォルダの下にあるフォルダなどは含まれません。連絡先の情報を含むすべてのフォルダを [連絡先] の直下に移動してください。
    >【不明点-2】>  CC_STR のような個人ごとにカスタマイズしたい情報をソースから追い出し、設定情報とするには>  どのような方法があるのでしょうか?
    ユーザー定義フィールドを追加し、そのフィールドの情報を Item オブジェクトの UserProperties により取得することで、個人ごとのカスタマイズ情報をプログラムから参照できます。手順などについてはいずれまとめて投稿します。
    >【不明点-3】>  直接上のソースの質問ではなく、差出人の名前を置き換えるサブプロシージャ(RewriteSender)についての質問です。>  メーリングリストなどを使って送信されたメールの場合、SenderEmailAddress の内容は送信者ではなくメーリングリストのアドレス>  が格納されてします。これを、実際の送信者(From)のアドレスで連絡先の検索を行いたいのですが、MailItem オブジェクトの構造>  を眺めているのですが、From 情報が見当たりません。どこをどのように参照すればよいでしょうか?
    SenderEmailAddress で取得できないのであれば、PR_SENT_REPRESENTING_EMAIL_ADDRESS プロパティで取得できるのではないかと思います。PR_SENT_REPRESENTING_EMAIL_ADDRESS は MailItem オブジェクトの PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0065001E") で取得できます。
    >【機能拡張-4】> ・ ”全員へ返信”や”返信”を行った場合、自動的にあて先を本文に設定する。 >【不明点-4】 >  ・どのようにすれば実現できるか教えてください。MailItem.Reply イベントトリガーとして実行させるものと予想しているのですが >  実装方法が分かっていません。
    Reply イベントでもできなくはないと思いますが、ちょっと面倒です。考え方を変えて、あて先を本文に設定して返信メッセージを作成するというマクロを作ってはどうでしょうか?たとえば、以下のようなマクロをつくり、これをアイテム作成のウィンドウのクイック アクセス ツール バーに登録しておけば、本文にあて先が設定された返信アイテムを作成ということが可能です。
    Public Sub ReplyAllToCurrentItem()    Dim objMail As MailItem    Dim objReply As MailItem    Dim objContact As ContactItem    Dim i As Integer        Set objMail = Application.ActiveInspector.CurrentItem    Set objReply = objMail.ReplyAll    For i = 1 To objReply.Recipients.Count        With objReply.Recipients.Item(i)            If .Type = olTo Then                Set objContact = FindContactByAddress(.Address)                If Not objContact Is Nothing Then                    objReply.Body = objContact.LastFirstAndSuffix & vbCrLf & objReply.Body                End If            End If        End With    Next    objReply.DisplayEnd Sub

  8. VBマクロ超初心者@豊田です。
     
    素早いレスポンスありがとうございます。
     
    >>【不明点-1】
    >objContacts.Folders に含まれるフォルダは、[連絡先] の直下にあるフォルダのみです。孫フォルダやほかのフォルダの下にあるフォルダなどは含まれません。>連絡先の情報を含むすべてのフォルダを [連絡先] の直下に移動してください。
    ★問題解決です!
    ”個人用の連絡先”というタイトルの下では、連絡先の各種フォルダがフラットに並んでいますが、確かにフォルダ移動時の画面で表示されたフォルダ階層では、[連絡先] の直下のフォルダ以外に孫フォルダがありました。
     
    >>【不明点-3】
    >SenderEmailAddress で取得できないのであれば、PR_SENT_REPRESENTING_EMAIL_ADDRESS プロパティで取得できるのではないかと思います。>PR_SENT_REPRESENTING_EMAIL_ADDRESS は MailItem オブジェクトの PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0065001E") で取得できます。

    ★問題解決です!
    ご指摘の通りで、メーリングリストの場合でもFROMアドレスが取得でき、期待するあて先を埋め込むことができました。
     
    >>【機能拡張-4】>> ・ ”全員へ返信”や”返信”を行った場合、自動的にあて先を本文に設定する。 >>【不明点-4】
    >Reply イベントでもできなくはないと思いますが、ちょっと面倒です。>考え方を変えて、あて先を本文に設定して返信メッセージを作成するというマクロを作ってはどうでしょうか?>たとえば、以下のようなマクロをつくり、これをアイテム作成のウィンドウのクイック アクセス ツール バーに登録しておけば、本文にあて先が設定された返信アイテムを作成ということが可能です。
     
    これは【機能拡張-2】のマクロを、アイテム作成のウィンドウのクイック アクセス ツール バーに登録することで、既に実現済みです。
    面倒くさがりの私は、その1クリックも削れないかと思っています。
     
    OUTLOOKでのメール送受信作業が快適になりつつありうれしい今日この頃です。
     
    次は、”メールの宛先を送信前に確認するマクロ”を参考に、宛先毎に複数のシグネチャーを選択して設定するマクロを作りたいと考えています。
    また、質問させてください。
     
    以上

  9. VBマクロ超超初心者たなべと申します。
     
    2.受信したメールの差出人を連絡先から検索する

    のマクロを、「Outlook VBA マクロ、はじめの一歩」の記載のように登録しましたが、
    マクロー再生を選択してもマクロ名が表示されず
    メール受信してもマクロが実行されません
    どうしたらよいか教えてください
     
    なお環境はOUTLOOK 2000です
     

  10. To たなべさん
    2. のマクロを実行させようとしているのでしょうか?
    その場合、残念ながら Outlook 2000 ではこのマクロが動作しません。
    メールを受信したときのイベントとして、このマクロでは NewMailEx というものを使っていますが、これが使えるのは Outlook 2003 以降になります。Outlook 2000 では NewMail というイベントでメッセージ受信時の処理が記述できるのですが、このイベントでは受信したメッセージのメッセージ ID が取得できないため、メッセージの受信は認識できても受信したメッセージは識別できないという問題があるのです。受信トレイのコレクションの ItemAdd イベントと併用すると受信したメッセージの識別も可能になるのですが、マクロが複雑になってくるので断念しました。受信時にすべての未読メッセージについて差出人を変更するというマクロなら以下で可能と思われますのでお試しください。
    Private Sub Application_NewMail()    Dim i As Integer    Dim c As Integer    Dim colItems As Variant
        Set colItems = Application.Session.GetDefaultFolder(olFolderInbox).Items.Restrict("[Unread] = True")    For i = 1 To colItems.Count        RewriteSender colItems(i).EntryID    NextEnd Sub

  11. 早速のご回答ありがとうございました
    回答いただいたマクロを
    2のマクロのメール受信時に発生するイベントの部分を入れ替えると
    FindContactByAddressが定義されていない関数というエラーメッセージが出ます
    どうしたらよいでしょうか?

  12. To たなべさん(ですよね?)
    2. のマクロを実行するには「0. メールアドレスから連絡先を検索する」で紹介している関数もマクロに登録してください。

  13.  初めましてVBマクロ超超初心者たなべの知り合いの、パソコン超超初心者の渡辺と申します。

    以前の質問から色々な事がありまして、現在Outlook 2003 を使用しています。そして『2. 受信したメールの差出人を連絡先から検索する』のマクロを作動させたいのですが、うまく作動しません。
    メール受信すると
    『Microsoft Visual BasicコンパイルエラーByRef引数の型が一致しません。』
    と表示されてしまいます。何が間違っているのでしょうか?
     
    ちなみにプログラムは
    『0. メールアドレスから連絡先を検索する』の

    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
    と『2. 受信したメールの差出人を連絡先から検索する』の
    \’ メール受信時に発生するイベント 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(strEntryID As String)     Dim objMail As MailItem    Dim objContact As ContactItem    Dim strSenderAddress As String        Set objMail = Application.Session.GetItemFromID(strEntryID)    strSenderAddress = objMail.SenderEmailAddress    Set objContact = FindContactByAddress(strSenderAddress)        If Not objContact Is Nothing Then        objMail.SentOnBehalfOfName = objContact.FileAs        objMail.Save    End IfEnd Sub
    をいれてます。
    また、サンプルの"hello world"は試してみた所、問題無く作動しました。
    一方、行おうと思っている方は、登録後『マクロを実行する』のツール→マクロ→マクロでも一覧に表示されず、マクロの登録そのものが出来ているのか怪しいです。いかんせん自分はパソコンそのものが、超ど素人なのでわからない事が多いですが、なんとか頑張ってこのマクロを使えるようになりたいので、なにとぞよろしくお願いします。

  14. すみません。EntryID が複数渡された時の処理に問題があったようです。
    Private Sub RewriteSender(strEntryID As String)
    という記述を
    Private Sub RewriteSender(ByVal strEntryID As String)
    に書き換えてください。

  15.  早速の御返答ありがとうございます。すぐに試させて頂いたのですが、今度は
    『Microsoft Visual Basicコンパイルエラーユーザ定義型は定義されていません。』
    という表示が出てしまい、プログラムの
    ”Private Function FindContactByAddress(strAddress As String)”
    という部分に黄色のパターンがかかり
    ”objContacts As Folder”
    が反転してます。
    全くもって意味はわからず、どうしていいかさっぱりです。お手数ですが教えてください。
    あと気になったのですが、マクロをデジタル署名して保存した後に、ツール→マクロ→マクロでも一覧が表示されず、実行ボタンも押せないのは問題ないのでしょうか?
    よらしくお願いします。
     

  16. すみません。Outlook 2007 と Outlook 2003 でクラス名が変わっている点を忘れてました。
        Dim objContacts As Folder

        Dim objContacts
    としてください。
    なお、この記事で紹介しているマクロはマクロメニューから直接実行されることを想定していないため、あえて Private として宣言しています。そのため、マクロの一覧に表示されなくても問題はありません。

  17.  またまた早速の御返事ありがとうございます。たった今試させて頂いたところ
    『万事O.K.でした!!!!!』
    周りのパソコン使える人に聞いても全くわからず、正直自分の様なパソコン素人では無理だろうと思っていましたが、丁寧にお答え頂いて何とか辿り着けました。ありがとうございます。
    たいした事では無いのかも知れませんが、今、猛烈に嬉しいです!!!
    本当ありがとうございました。また、わからない事があったときは質問させていただきます。よろしくお願いします。

  18. はじめまして。この記事のマクロを登録し、快適に使わせてもらっています!ありがとうございます。ところがこの度 Office2007 SP2をインストールしたところ、下記場所でエラーになって止まってしまいます。\’ 差出人の名前を置き換えるサブプロシージャ の中の objMail.Save何か解決策がないかMSDNのページなど見てみたのですが、当方全くの初心者ということもあり、分かりません!もしよかったら解決策を教えて頂けませんでしょうか?宜しくお願い致します。

  19. To haya haya さんこちらで SP2 の動作を確認しましたが、Save でエラーが発生するということはありませんでした。具体的にどのようなエラーになったのでしょうか?

  20. ご返事ありがとうございます!エラーですが、以下のようなメッセージとなります。実行時エラー’-2147221239 (80010109)’:メッセージを変更できないため、操作を実行できません。デバッグボタンを押すと、 \’差出人の名前を置き換えるサブプロシージャ の中のobjMail.Saveのところで(黄色い矢印がついて)止まっています。VBA中の登録方法ですが、「ThisOutlookSession」に書いているんですが、これは問題ないでしょうか?申し訳ありませんが、ご助言をお願いいたします。

  21. 不安なのでスクリーンショットを自分のプロフィールページのアルバムに載せてみました。もし良かったら見てみていただけますでしょうか?よろしくお願いいたします。m( __ __ )m

  22. 画像を見たところ、エラーは 0x80040109 のようですね。このエラーコードの意味はアイテムを変更して保存しようとした際に、別のセッションで変更が行われたという意味です。原因はわかりませんが、このエラーが出る場合はいったん編集を破棄して再度保存する必要があります。以下のように変更してみましたので試してみてください。
    ' 差出人の名前を置き換えるサブプロシージャ
    Private Sub RewriteSender(ByVal strEntryID As String)
    Dim objMail As MailItem
    Dim objContact As ContactItem
    Dim strSenderAddress As String

    Set objMail = Application.Session.GetItemFromID(strEntryID)
    strSenderAddress = objMail.SenderEmailAddress
    Set objContact = FindContactByAddress(strSenderAddress)
    If Not objContact Is Nothing Then
    On Error Resume Next
    objMail.SentOnBehalfOfName = objContact.FileAs
    objMail.Save
    If Err.Number = &H80040109 Then
    Set objMail = Application.Session.GetItemFromID(strEntryID)
    objMail.SentOnBehalfOfName = objContact.FileAs
    objMail.Save
    End If
    End If
    End Sub

  23. Millefeuilleさん早速の対応ありがとうございます!そして、ばっちり直りました!これからも参考にさせていただきます。本当にありがとうございました。

  24. 「受信したメールの差出人を連絡先から検索する」ですが、Outlookが立ち上がっているときに入ってくるメールに対しては有効に動作しますが、立ち上がり前に入っていたメールに対しては有効になりません。そのような場合、手動で「受信トレイ」にあるメールに対して「受信したメールの差出人を連絡先から検索する」を適用したいのですが、どのようにしたらよいでしょうか。

  25. To 一哉さん受信トレイにあるメールに対して差出人を連絡先の名前に置き換えるマクロは以下の通りになります。Public Sub RewriteSenderInInbox() Dim objMail \’As MailItem Dim objContact As ContactItem Dim strSenderAddress As String For Each objMail In Application.Session.GetDefaultFolder(olFolderInbox).Items strSenderAddress = objMail.SenderEmailAddress Set objContact = FindContactByAddress(strSenderAddress) If Not objContact Is Nothing Then objMail.SentOnBehalfOfName = objContact.FileAs objMail.Save End If NextEnd Sub

    • Millefeuille様:

      上記マクロを導入しましたが、”型が一致しません”という
      エラーで実行がされません。

      上記マクロの、
      Dim objMail \’As MailItem
         ↓
      Dim objMail As MailItem

      という部分を修正しないとマクロが動かなかったのですが、
      なお仕方を間違えたのでしょうか?

      助言をいただければと思います。

      当方環境:
      OS:XP SP3
      OUTLOOK:2003SP3

      以上、よろしくお願いします。

      • ブログの移転の際にコメントに不要な文字が含まれてしまったようです。下記が正しいコードです。

        Public Sub RewriteSenderInInbox()
        Dim objMail 'As MailItem
        Dim objContact As ContactItem
        Dim strSenderAddress As String
        For Each objMail In Application.Session.GetDefaultFolder(olFolderInbox).Items
        strSenderAddress = objMail.SenderEmailAddress
        Set objContact = FindContactByAddress(strSenderAddress)
        If Not objContact Is Nothing Then
        objMail.SentOnBehalfOfName = objContact.FileAs
        objMail.Save
        End If
        Next
        End Sub

  26. Millefeuille様早急な御回答ありがとうございました。完璧な動作を確認しました。本当にありがとうございました。

  27. 教えてください.あて先に指定したアドレスの名前を本文に追加する方法ですが,マクロサンプルリンクからPublicSubAddHeader()でVBAを登録したのですが,コンパイルエラー SubまたはFunctionが定義されていませんとエラーが出てきてしまいます.アドバイスをよろしくお願いいたします

  28. 回答が遅くなりましてすみません。Public Sub AddHeader だけではマクロは動作しません。その上の FindContactByAddress も登録してください。

    • UnKnownです. 。Public Sub AddHeader だけではマクロがいまだに駄目です.FindContactByAddressの登録とはどのように行うのでしょうか?お手数おかけいたしますがよろしくお願いいたします

  29. Millefeuille さまご回答ありがとうございました.Project1 – ThisOutlookSession (コード)]に両方を入力し,マクロを VbaProject.OTM を保存しましたが動きません.Outlook 2010はだめなのでしょうか?

    • 動かないというのは、何かのエラーが出るということでしょうか?
      それとも、何もエラーが出ずに動作しないということでしょうか?
      もし、エラーが出るのであればエラーの内容を教えてください。
      また、エラーが出ないのであれば、以下のコードをマクロに記述して実行し、メッセージが表示されるかを確認してみてください。

      Public Sub Test()
      MsgBox “Hello World.”
      End Sub

      • Public Sub Test() MsgBox “Hello World.”End Sub は動作確認できます.
        エラーは,Public Sub AddHeader()の黄色いマーカーとFindContactByAddressの青いマーカーで示されることからこれを何とかしないとだめなのでしょうか?

      • AddHeader は FindContactByAddress がなければ動きません。
        もう一度記事を最初から読み返してみてください。

      • Outlooklabさま ありがとうございました。まず、0のFind ContactByAddressをいれ1のAddHeaderをいれ、エラーは出なくなりました。
        今度は、「オブジェクト変数またはWith ブロック変数が設定されていません」とでます。これを解決するにはどうすればよろしいでしょうか?何卒 よろしくお願いいたします.

      • AddHeader を実行したときにエラーになるということでしょうか?
        その場合、新規メッセージの作成ウィンドウは開いているのでしょうか?

  30. 再掲示いただいたものを実行してみたところ

    ”オブジェクトは、このプロパティまたはメソッドをサポートしていません。”

    というエラーが出てしまいます。

    Outlook2003ではどこか修正が必要なのでしょうか?
    VBA素人のためどこに手を入れたら良いのかが分かりません。

    お願いばかりで申し訳ありませんが、修正箇所を
    お教えいただければと思います。

    以上、よろしくお願いします。

      • 迅速な対応ありがとうございました。
        思ったとおりの動作をするようになりました。

        おかげさまで、Outlookの利用環境が大幅に向上いたしました。

        追加で、ずうずうしいお願いではありますが、送信済みメールについても同様に置き換えるのは難しいでしょうか?

        以上、よろしくお願いします。

      • 記事のマクロに下記を追加することで送信済みメールを置き換えるのも可能ですが、送信済みメールの差出人はすべて自分なのではないでしょうか?

        Public Sub RewriteSenderInSentMail()
        On Error Resume Next
        Dim objMail ‘As MailItem

        For Each objMail In Application.Session.GetDefaultFolder(olFolderSentMail).Items
        RewriteSender objMail.EntryID
        Next
        End Sub

  31. 返答いただきありがとうございます。
    また、説明不足で申し訳ありません。

    送信メールの”宛先”について、表示名の置き換えが出来ないかと考えました。

    同じ人からいただいたメールで、メールアドレスに表示名が付いたり、付かなかったり、他の方が発信したメールの転送・返信メールだと表示名が異なっていたりするため、自分でメール返信等を行った後に、名前でソート等を行うと、これらが全て別人として扱われ不便なため、受信メール同様、Outlook上だけでも、表示名の統一ができないかと思ったものです。
    (メール返信時にメールアドレスを統一できればこんなことが起こらないのですが、急ぎの場合に失念したり、既に送信済のメールもあるため)

    以上、よろしくお願いします。

    • メールの返信の際に宛先の表示名を連絡先のものに置き換えるマクロはあるので、これを流用して送信済みアイテムのメッセージが変更できるか試してみます。

  32. VBA 初心者のYUICIです。
    RewriteSenderInInboxのマクロで、開いているべつのPSTファイルのフォルダーに適用させるにはどのようにすればよろしいでしょうか。
    たとえば【個人フォルダー2010年】にある【メール】というフォルダーにある送信者名に適用するような場合です。
    よろしくお願いします。

    • 下記のマクロで現在表示中のフォルダーの差出人を書き換えることができます。
      Public Sub RewriteSenderInCurrentFolder()
      On Error Resume Next
      Dim objMail ‘As MailItem

      For Each objMail In Application.ActiveExplorer.CurrentFolder.Items
      RewriteSender objMail.EntryID
      Next
      End Sub

  33. お世話になっております。高井と申します。
    上記マクロをOutlook2007で使用してみましたが、
    Private Sub RewriteSender(ByVal strEntryID As String)
    の行で「sub または function が定義されていません」のエラーが表示されてマクロを実行することができません。
    「Hello,World」のマクロは実行できました。
    何卒ご教示お願いいたします。

  34. はじめまして、keiと申します。
    「受信トレイの差出人の名前を置き換える」マクロをOutlook2010で使用しようとしたところ、動作はエラーなく終了するものの差出人の表示が変わりません。
    このマクロが参照している場所は、連絡先に登録されている情報の、具体的にどこになるのでしょうか?
    連絡先に記載の内容が問題なのではないかと思っております。
    よろしくお願いいたします。

    • 置き換えているのは連絡先の「件名」(アドレス帳で名前として表示される文字列)です。
      連絡先フォルダーが複数存在していたりしますか?
      その場合、マクロを変更する必要があります。

  35. keiです。お返事いただきありがとうございます。
    連絡先フォルダーは1つしかありません。

    連絡先(フォルダではなく)を開いても「件名」 という項目が見当たらず、
    画面が基本情報?と、インターネット、電話番号、住所と別れており、
    基本情報には フリガナ、姓/名、勤務先、部署、役職、表題
    インターネットには 電子メール、表示名、Webページ
    電話番号には 勤務先電話、勤務先FAX
    住所には 勤務先住所、郵便番号/都道府県、市区町村、番地、国/地域名
    が表示されています。

    連絡先の中では 「表題」 か 「姓/名」 が漢字表記になっています。

    アドレス帳を開くと、名前、表示名、電子メールアドレスがありますが、こちらの「名前」は
    漢字のみで表示されています。
    ただし、メールの差出人は アルファベット+漢字名+部署名となっており、「名前」に
    表示されているものとは一致していません。

    大変申し訳ありませんが、連絡先の 「表題」 に置き換える場合、マクロのどこを
    どう置き換えればよいのでしょうか?
    自分で調べてはみましたが、マクロの知識もほとんどないためまるでわかりませんでした。。。
    あつかましいお願いですが、ご助言、よろしくお願いいたします。

    • 失礼しました。
      現在のマクロで「表題」のほうを取得していました。
      となると、表題に設定されている文字列で置き換えられないということですね。
      連絡先フォルダーも一つしかないとなると、ちょっと原因がわかりません。
      新着メッセージでも動作しないのでしょうか?

      • 今更で申し訳ないのですが・・・

        本マクロがうまく動作せず悩んでいたのですが、
        本マクロは”表示名”を取得するのだと思っていたのですが実際には”表題”を
        収録しているとのことですが、どの部分を修正すれば、”表示名”を取得するように
        変更できるのかをお教え願えないでしょうか?

        よろしくお願いします。

      • 表題ではなく表示名を取得するには、
        objMail.SentOnBehalfOfName = objContact.FileAs

        objMail.SentOnBehalfOfName = objContact.FullName
        としてください。

  36. こんにちは、ご回答ありがとうございます。
    新着メッセージでも動作しません。

    ・・・・で、会社の同僚とも話したのですが、そもそも今現在表示されている差出人名が
    メールアドレスでもなければ、連絡先のなかのどの項目とも一致しないのがいけないのかも、
    という話になりました。
    連絡先の複数の項目をつなげたような表記になっているので、そもそも、それがいけないのかも
    しれません、、、。
    会社で一律に作成している連絡先ですのでこちらで1つ1つ手直ししなくてもできるように
    したいとは思っています。
    連絡先と比較しているのはメールアドレスそのものなのでしょうか?
    outlookに詳しくないのでよくわかりませんが、会社の仕様なのか受信メールの中にも差出人と
    同じ表現でメールアドレスそのものはどこにも表示されていません。

    どのようにすればそれぞれの値を取得できているのかすら、今は確認できないレベルですので
    もう少しマクロを勉強してみます、、、。

    お騒がせいたしました。
    またうまくいきましたら、投稿させていただきます。
    kei

  37. こんにちは、先日、いろいろ教えていただいたkeiです。

    e-mailアドレスで連絡先を検索することが上手くできなかったため、
    結局、表示される差出人の文字列からほしい文字列を取り出して、
    その文字列で差出人名を置き換えることができるようになりました。
    しかし、ちょっと問題が、、、。

    objMail.SentOnBehalfOfName = objContact.FileAs

    という個所を、置き換えたい文字列である buf_name にすることで

    objMail.SentOnBehalfOfName = buf_name

    受信メールはうまく置き換わるのですが、会議開催連絡のメールだと
    これが上手く動きません。

    だめな場合に置き換えできなくてもSkipできればよいのですが、そのやり方も
    わかりません、、、。

    会議開催通知のメールに対して、何か処理を変えないといけないのでしょうか?
    または置き換えできない際に、そのアイテムをSkipして次に移ることはできない
    でしょうか?

    よろしくお願いいたします。

    • 会議出席依頼メールには SentOnBehalfOfName というプロパティがないため、名前の置き換えはできません。
      以下のようにしてスキップさせてください。
      If objMail.MessageClass = “IPM.Note” Then objMail.SentOnBehalfOfName = buf_name

  38. keiです、コメントありがとうございます。

    頂いたコードにすると、エラーは出なくなりましたが、メールの差出人名の置き換えもできなく
    なってしまいました、、、。

    いろいろ調べて試したみたところ、現状は下記のようなコードでどうにか
    希望通りのことができています。
    (おかしな記述などもあるとは思うのですが、いかんせん、よくわかっていないものですみません)

    本当は会議開催通知も差出人の名前は取得できているので、置き換えできないのかとも
    思っているのですが、何を置き換えればよいのか調べてもわからず、うまくいきません、、、。

    差出人の記述は下記のような構成になっています。
    会議開催でも見た目は同じで buf_name まではうまく動いたのですが、、、。

    例) Taro Suzuki(鈴木 太郎 社名 部門名)

    ==== ここから ===
    Public Sub Testtest()
    Dim objMail ‘As MailItem
    Dim objContact As ContactItem

    Const PR_SENT_REPRESENTING_EMAIL_ADDRESS = “http://schemas.microsoft.com/mapi/proptag/0x0065001e”
    Const PR_SENT_REPRESENTING_NAME = “http://schemas.microsoft.com/mapi/proptag/0x0042001e”
    Dim strFromAddress As String
    Dim strFromName As String
    Dim buf As String
    Dim buf_name As String
    Dim nametmp As Variant
    Dim n As Integer
    Dim objReply As MailItem

    For Each objMail In Application.ActiveExplorer.CurrentFolder.Items
    strFromName = objMail.PropertyAccessor.GetProperty(PR_SENT_REPRESENTING_NAME)

    n = InStr(strFromName, “(“)
    buf = Mid(strFromName, n + 1)
    nametmp = Split(buf, ” “)

    If InStr(1, buf, ” “) < 1 Then
    buf_name = nametmp(0)
    Else
    buf_name = nametmp(0) & " " & nametmp(1)
    End If

    If objMail.Class = olMail Then
    objMail.SentOnBehalfOfName = buf_name
    objMail.Save
    End If

    Next

    End Sub
    =============== ここまで =========
    いずれにしても、たくさんの助言を頂き、どうにかほどほど満足する
    ものができました。

    本当にありがとうございました。

  39. 初めまして、VBA 初心者のSHINGOです。
    RewriteSenderInInboxのマクロで、”連絡先”に登録してある名称は受信トレイの差出人の名前を置き換えてくれるのですが、
    これを「検索する連絡先を”パブリックフォルダの連絡先”」にすることは可能でしょうか?
    よろしくお願いします。

    • 可能ですが、ちょっと手間がかかります。また、バージョンによって指定方法が異なります。
      お使いの Outlook のバージョンはいくつでしょうか?

  40. 返信いただいたのにコメントが遅くなって申し訳無いです。
    OUTLOOK2007を使用しています。
    宜しくお願いします。

  41. ご回答ありがとうございます。

    お陰様でパブリックフォルダを参照するようにできました。

    恐縮ですが追加で教えて頂きたいのですが
     「パブリック フォルダ>すべてのパブリック フォルダ>連絡先」の中に
     連絡先を分類(フォルダ分け)してまして、例を挙げますと、

    ・パブリック フォルダ>すべてのパブリック フォルダ>連絡先>A>a…[ア]
    ・パブリック フォルダ>すべてのパブリック フォルダ>連絡先>A>b…[イ]
    ・パブリック フォルダ>すべてのパブリック フォルダ>連絡先>B>c…[ウ]
    ・パブリック フォルダ>すべてのパブリック フォルダ>連絡先>B>d…[エ]

    のようになっています。

    [ア]だけなら動作するのですが、他の[イ][ウ][エ]
     もアドレスから名前に置き換えるにはマクロ分けするしかないのでしょうか?

    宜しくお願いします。

    • プログラムを書き換えれば、特定のフォルダーのサブフォルダーをすべて検索するような処理も可能です。
      サンプルを作りますのでしばらくお待ちください。

    • ありがとうございます、たった今試させて頂いた所、バッチリでした!!
      長年悶々としていたものがすっきり解消されました!!
      周りにOUTLOOKというか、マクロに詳しい人がおらず無理だろうと思っていましたが、
      このサイトにたどり着いて、本当に良かったと思います。
      また、わからない事があったときは質問させていただきます。どうぞよろしくお願いします。

  42. いつも拝見させていただいております。

    社内環境がExchangeへ移行してから、FindContactByAddress() が正しく動作しな現象がでています。

    デバッグしてみたところ、Contacts で管理されているItemsとして登録されているアドレス帳のアイテムでは
    MailAdressのType が、”EX” となっているものがあり、この場合”/o=XXXX”形式でメールアドレスが設定
    されているため、検索に失敗しているものと思われます。

    メールからアドレスを取り出す際に、.AddressEntry.Type を判断して、.PropertyAccessor.GetProperty(PR_SMTP_ADDRESS)
    で取得していますが、同様に”EX”タイプのアドレス帳を”SMTP”タイプのメールアドレスから検索する方法はないでしょうか?

    • EX のアドレスの連絡先を SMTP のメールアドレスで検索することは困難と思われます。
      宛先のメールアドレスを取得する際には、Exchange 組織内のユーザーは EX アドレスになっていますので、Address プロパティで FindContactByAddress による検索を行えばよいのではないかと思います。

  43. はじめまして。
    教えていただきたいことがありましてコメントさせていただきます。
    連絡先をマクロで活用を利用させていただいたのですが、5のコメントにあったメーリングリストの件で当方も困っております。
    ご質問者様は8で解決なられたようですが、具体的にはどのようなコードを書くと実現できますでしょうか?
    (“http://schemas.microsoft.com/mapi/proptag/0x0065001E") で取得できます。とあるのですがリンク切れになっていまして、結局どうすればよいかわからなかったもので質問させていただく次第です。

コメントを残す

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

WordPress.com ロゴ

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

Twitter 画像

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

Facebook の写真

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

Google+ フォト

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

%s と連携中