【Outlook VBA】メールの署名にハイパーリンクを追加する方法

前回の「【Outlook VBA】カンタン！送信する宛先のドメイン毎に署名を切り替える」にて、署名部分にハイパーリンクを挿入する方法の質問がありましたので、ご紹介したいと思います。

【Outlook VBA】カンタン！送信する宛先のドメイン毎に署名を切り替える

はじめに

今回行いたいことはOutlookでメールを作成する際に挿入する署名にハイパーリンクを挿入する内容となります。

なお、テキスト形式を選択している方はハイパーリンクは表示されませんので、HTML形式かリッチテキスト形式に変更をお願いします。

設定方法

早速設定方法をご説明します。
①リボンメニューの「メッセージ」タブ、「署名」アイコンをクリックし、「署名」を選択します。

②編集する署名を選択します。

③ハイパーリンクを挿入したい箇所をマウスで選択し、右横の「リンク」アイコンをクリックします。

④「アドレス」欄へリンク先を入力し、「OK」をクリックします。

選択範囲がハイパーリンクに変わったら成功です。

⑥最後に新規メールを作成し、ハイパーリンクが挿入されていることを確認します。

前回紹介したスクリプトに処理を追加

前回の「【Outlook VBA】カンタン！送信する宛先のドメイン毎に署名を切り替える」にて紹介しましたスクリプトにハイパーリンクを追加した署名になるよう変更を加えてみましたのでこちらも利用いただければと思います。

【Outlook VBA】カンタン！送信する宛先のドメイン毎に署名を切り替える

設定は以下2点を変更してください。
①署名でハイパーリンクにしたいURLを指定します。
Const myHyperlink = “https://extan.jp”

②社外用署名の後尾にハイパーリンク変数「myHyperlink」を追加します
Const signature2 = “————” & vbCrLf & “（社外）〇〇〇株式会社　〇〇部〇〇課” & vbCrLf & “えくた　たろう（#代表番号）” & vbCrLf & myHyperlink

Public Sub 署名変更にハイパーリンク追加()

    '社内用と社外用の署名を定義
    Const signature1 = "（社内）〇〇部　えくた　たろう（#内線）"
    
    'ハイパーリンクを定義します
    Const myHyperlink = "https://extan.jp"
    '社外用署名の後尾にハイパーリンク変数を追加します
    Const signature2 = "------------" & vbCrLf & "（社外）〇〇〇株式会社　〇〇部〇〇課" & vbCrLf & "えくた　たろう（#代表番号）" & vbCrLf & myHyperlink

    
    Dim myDomainList As Variant
    Dim checkNum As Long
    Dim Item As Object
    Dim recips As Object
    Dim pa As Object
    Dim senderDomainList As Variant
    Dim bookmark As Object
    Dim signature As Object
    Dim objSearchWord As Object
    
    'チェックナンバー初期化
    checNum = 0
    
    '指定ドメイン（社内ドメインとして定義します。該当しない場合は社外とします。）
    myDomainList = Array("extan.jp", "extan2.jp")
    
    'outlookオブジェクトの名前空間を指定
    Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
    Set Item = ActiveInspector.CurrentItem
    Set recips = Item.Recipients
    
    '宛先のSMTPアドレスを取得
    Set pa = recips(1).PropertyAccessor
    'ドメインだけにする
    senderDomainList = Split(pa.GetProperty(PR_SMTP_ADDRESS), "@")
    
    '社内ドメインと宛先のドメインが一致しているかチェック　一致した場合は1を代入。
    For i = 0 To UBound(myDomainList)
        If myDomainList(i) = senderDomainList(1) Then
            checkNum = 1
        End If
    Next

    '本文のオブジェクトを取得
    Set bookmark = ActiveInspector.WordEditor
    '署名のオブジェクトを取得
    Set signature = bookmark.Bookmarks("_MailAutoSig")
   
    
    '署名の置き換え
    If checkNum = 1 Then
        signature.Range.Text = signature1
    Else
        signature.Range.Text = signature2

        '本文のオブジェクトを再取得
        Set bookmark = ActiveInspector.WordEditor
        Set objSearchWord = bookmark.Range
        
        'myHyperlinkのワードを探し一致していればハイパーリンクを挿入
        While objSearchWord.Find.Execute(FindText:=myHyperlink, MatchWholeWord:=True, Forward:=True) = True
              bookmark.Hyperlinks.Add Anchor:=objSearchWord, Address:=myHyperlink
              objSearchWord.Collapse Direction:=wdCollapseEnd
        Wend
        
    End If

    'オブジェクトの開放
    Set Item = Nothing
    Set bookmark = Nothing
    Set signature = Nothing
    Set objSearchWord = Nothing
    
End Sub

実行すると、はい！ハイパーリンクになっていますね！