返信や転送の際の本文のヘッダー内でアドレスをハイパーリンクにする


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


OEでは、相手からの受信したメールを返信または転送した際に
送信先の相手はそのメール内にあるccやtoなどのメールリンクが有効になっており
アドレスを参照することができました。
OUTLOOK2010では、メールリンクがすべてテキスト化されてしまい
アドレスを参照することができません。

この場合は、どのようにしたらリンクが残せるでしょうか。


Outlook には返信や転送のメール本文に含まれるヘッダー情報の宛先などをリンクにする機能はないため、そのような処理をするマクロを作ってみました。
下記マクロの ReplyAllWithLinkedHeader を実行すると全員に返信、ForwardWithLinkedHeader を実行すると転送となり、それぞれ本文のヘッダーの宛先などにリンクが設定されます。(テキスト形式の場合は表示名の横に mailto: としてアドレスが追加されます。)

' ここをトリプルクリックでマクロ全体を選択できます。
' ヘッダーにリンクをつけて全員に返信するプロシージャ
Public Sub ReplyAllWithLinkedHeader()
    Dim objMail As MailItem
    Dim objReply As MailItem
    Set objMail = GetActiveMail()
    Set objReply = objMail.ReplyAll
    LinkHeader objMail, objReply
    objReply.Display
End Sub
' ヘッダーにリンクをつけて転送するプロシージャ
Public Sub ForwardWithLinkedHeader()
    Dim objMail As MailItem
    Dim objForward As MailItem
    Set objMail = GetActiveMail()
    Set objForward = objMail.Forward
    LinkHeader objMail, objForward
    objForward.Display
End Sub
' アクティブなウィンドウを元にアイテムを取得する関数
Private Function GetActiveMail() As MailItem
    If TypeName(ActiveWindow) = "Inspector" Then
        Set GetActiveMail = ActiveInspector.CurrentItem
    Else
        Set GetActiveMail = ActiveExplorer.Selection(1)
    End If
End Function
' ヘッダーをリンクにするプロシージャ
Private Sub LinkHeader(objOrg As MailItem, objNew As MailItem)
    Dim iPtr As Integer
    Dim objRec As Recipient
    iPtr = 1
    LinkOneName objNew, objOrg.Sender, iPtr
    For Each objRec In objOrg.Recipients
        LinkOneName objNew, objRec.AddressEntry, iPtr
    Next
End Sub
' 一つのアドレスをリンクにするプロシージャ
Private Sub LinkOneName(objNew As MailItem, addrEntry As AddressEntry, iPtr As Integer)
    On Error Resume Next
    Const PR_SMTP_ADDRESS = "http://schemas.microsoft.com/mapi/proptag/0x39fe001e"
    Dim strName As String
    Dim strAddress As String
    Dim strLinked As String
    strName = addrEntry.Name
    strAddress = addrEntry.Address
    If LCase(Left(strAddress, 3)) = "/o=" Then
        Dim strSmtp As String
        strSmtp = addrEntry.PropertyAccessor.GetProperty(PR_SMTP_ADDRESS)
        If strSmtp <> "" Then
            strAddress = strSmtp
        End If
    End If
    If objNew.BodyFormat = olFormatPlain Then
        strLinked = strName & " <mailto:" & strAddress & ">"
        objNew.Body = Left(objNew.Body, iPtr - 1) & Replace(objNew.Body, strName, strLinked, iPtr, 1)
        iPtr = InStr(iPtr, objNew.Body, strLinked) + Len(strLinked)
    Else
        strLinked = "<a href=""mailto:" & strAddress & """>" & strName & "</a>"
        objNew.HTMLBody = Left(objNew.HTMLBody, iPtr - 1) & Replace(objNew.HTMLBody, strName, strLinked, iPtr, 1)
        iPtr = InStr(iPtr, objNew.HTMLBody, strLinked) + Len(strLinked)
    End If
End Sub

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

広告

返信や転送の際の本文のヘッダー内でアドレスをハイパーリンクにする」への2件のフィードバック

  1. Outlook2007にて実行しようとしたところ、”オブジェクトはこのプロパティまたはメソッドをサポートしていません”と表示されてしまいます。

    具体的にはステップイン実行していった際にヘッダーをリンクにするプロシージャ内、
    >LinkOneName objNew, objOrg.Sender, iPtr
    実行後に438エラーが表示されます。

    ちなみに以前はCC名をリンクにする、ではなく名前で表示されていたものを
    アドレス表示にするといったVBAが無かったでしょうか?
    (Outlookで、返信時にThunderbirdのようにアドレスのみで表示したいのです)

コメントを残す

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

WordPress.com ロゴ

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

Twitter 画像

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

Facebook の写真

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

Google+ フォト

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

%s と連携中