VBAでOutlookのメール作成でリンク付きのコメントを自動で挿入したい。

Question

前提・実現したいこと

キーワードが一致した場合、そのコメントをメールに貼り付けるような送信メールを作成したいのですが構文の書き方が分かりません。コメントは3通りあります。コメントの一部はリンクをクリックするようにしたいですがうまくいきません。

Sub メール通知()

Dim objOutlookApp As Object
Dim objMail As Object
Dim Rng As Range
Dim intintNum As Integer
Dim strBody As String
Dim strTag1 As String
Dim strTag2 As String
Dim strTag3 As String
Dim strTag4 As String
Dim strTag5 As String
Dim strBr As String
Dim strSubject As String
Dim strSTname_Template As String
strBr = vbLf '改行コード


'「メール」シートのA列最終行まで処理を繰り返します。
For intNum = 3 To Worksheets(2).Cells(1048576, 1).End(xlUp).Row + 1

    '「メール」シートのA列載せるに値があればメール作成・送信処理を継続します。
    If Worksheets(1).Cells(intNum, 1) <> "" Then

        'メールテンプレートを設定します。
        strSTname_Template = Worksheets(1).Range("B1").Value
    
        'メールテンプレートの指定が無い場合は警告表示および処理を中断します。
        If strSTname_Template = "" Then
            MsgBox "B" & intNum & "にテンプレートシートを指定してください。"
            Exit Sub
        End If
    
        
        'Outlook.Applicationを呼び出し、セットします。
        Set objOutlookApp = CreateObject("Outlook.Application")
        Set objMail = objOutlookApp.CreateItem(olMailItem)
        
        
        'メール宛先・本文シート記載の値を変数に入れます。
        strTag1 = Worksheets(1).Range("G" & intNum).Text
        strTag2 = Worksheets(1).Range("C" & intNum).Text
        strTag3 = Worksheets(1).Range("D" & intNum).Text
        strTag4 = Worksheets(1).Range("E" & intNum).Text
        strTag5 = Worksheets(1).Range("F" & intNum).Text
        
        'テンプレートのメール本文の箇所を読み込み、変数に入れます。
        For Each Rng In Worksheets(strSTname_Template).Range(Worksheets(strSTname_Template).Range("A5").Value)
            strBody = strBody & Rng.Value & vbLf
        Next Rng
        
        'メール本文中のタグを指定データへ置換します。
        strBody = Replace(strBody, "<Tag1>", strTag1)
        strBody = Replace(strBody, "<Tag2>", strTag2)
        strBody = Replace(strBody, "<Tag3>", strTag3)
        strBody = Replace(strBody, "<Tag4>", strTag4)
        strBody = Replace(strBody, "<Tag5>", strTag5)
        
        With objMail
            .BodyFormat = ２ ' 「3」の場リッチテキスト型となります。「1」はテキスト型、「2」は HTML型となります。
            .To = Worksheets(1).Range("H" & intNum).Value
            .CC = Worksheets(1).Range("I" & intNum).Value
            
    
            '本文をBodyプロパティにセットします。
            .Body = Worksheets(1).Range("C" & intNum).Value & strBr & Worksheets(1).Range("D" & intNum).Value & strBr & strBr & strBody
    
            
            'テンプレートからタイトルを読み込みます。
            strSubject = Worksheets(strSTname_Template).Range("A2").Value
            
            'タグ部分を置換します。
            strSubject = Replace(strSubject, "<Tag1>", strTag1)
            strSubject = Replace(strSubject, "<Tag2>", strTag2)
            strSubject = Replace(strSubject, "<Tag3>", strTag3)
            strSubject = Replace(strSubject, "<Tag4>", strTag4)
            strSubject = Replace(strSubject, "<Tag5>", strTag5)
           
            Dim i As Long
          Dim LastRow As Long
          LastRow = Range("A1048576").End(xlUp).Row
          For i = 3 To LastRow
          If Cells(i, 3) = "S" Then
          Cells(i, 10) = "詳細は <a href="https://www.google.co.jp/">こちら</a>。問い合わせ先は<a href="mailto:[e-mail]">こちら</a>"
          
          ElseIf Cells(i, 3) = "M" Then
          Cells(i, 10) = "詳細は <a href="https://www.google.co.jp/">こちら</a>。問い合わせ先は<a href="mailto:[e-mail]">こちら</a>"
          Else
           Cells(i, 10) = "詳細は <a href="https://www.google.co.jp/">こちら</a>。問い合わせ先は<a href="mailto:[e-mail]">こちら</a>"
          End If
          Next         
            
            
    
            .Subject = strSubject
                          
            
            Select Case Worksheets(1).Cells(intNum, 1)
            Case "未"
                'メールを表示します。
                .Display
            Case Else
                MsgBox "値が異なります。「未」か「済」を入力してください。"
            End Select
            
            
            
        End With
        'メール本文をクリアします。
        strBody = ""
    
    End If
    
Next intNum

MsgBox "メール作成が完了しました。"

Set objOutlookApp = Nothing
Set objMail = Nothing

End Sub

試したこと

下記を作成しましたが、エラーとなってしまいます。
Dim i As Long
Dim LastRow As Long
LastRow = Range("A1048576").End(xlUp).Row
For i = 3 To LastRow
If Cells(i, 3) = "S" Then
Cells(i, 10) = "詳細は <a href="https://www.google.co.jp/">こちら１</a>。問い合わせ先は<a href="mailto:[e-mail]">こちら１</a>"
ElseIf Cells(i, 3) = "M" Then
Cells(i, 10) = "詳細は <a href="https://www.google.co.jp/">こちら２</a>。問い合わせ先は<a href="mailto:[e-mail]">こちら２</a>"
Else
Cells(i, 10) = "詳細は <a href="https://www.google.co.jp/">こちら３</a>。問い合わせ先は<a href="mailto:[e-mail]">こちら３</a>"
End If
Next

Answer 1

まず、HTML のタグを本文に使いたいなら、Body ではなく HTMLBody を使います。
また、"" の中で " を使いたければ、"" と記載する必要があります。
例えば、以下のような形になります。

objMail.HTMLBody = "詳細は <a href=""https://www.google.co.jp/"">こちら１</a>。問い合わせ先は<a href=""mailto:[e-mail]"">こちら１</a>"

Comments

[koko2]

コメントありがとうございました。リンクで表示することができました。ただ、<Tag1>から<Tag5>が表示されなくなりました。難しいです。
Dim i As Long
Dim LastRow As Long
LastRow = Range("A1048576").End(xlUp).Row
For i = 3 To LastRow
If Cells(i, 3) = "S" Then
objMail.HTMLBody = "詳細は <a href=""https://www.google.co.jp/"">こちら1</a>"
ElseIf Cells(i, 3) = "M" Then
objMail.HTMLBody = "詳細は <a href=""https://www.google.co.jp/"">こちら2</a>"
Else
objMail.HTMLBody = "詳細は <a href=""https://www.google.co.jp/"">こちら3</a>"
End If
Next

[millefeuille]

strBody に設定した本文を "詳細は..." の前に追記したければ、以下の様にすればよいと思います。

objMail.Body = strBody
objMail.HTMLBody = objMail.HTMLBody & "詳細は <a href=""https://www.google.co.jp/"">こちら1</a>"

[koko2]

ありがとうございます。無事に処理ができました。
自分で色々とコードを書き換えていたのですがなかなか解決できずにいたので、とても助かりました。

Answer 2

文面を書き換えるだけなら、VBAの追記を元に戻し、「TAG4」や「TAG5」を活用したほうがいいのではないでしょうか。
VBAの編集はやめて、Excel側で必要な情報を揃えたほうが良いかもしれません。
Excel内でやるのであれば、vlookupなどで必要なデータを整理できると思います。

Comments

[koko2]

回答ありがとうございました。
試しに<Tag>を追加してみたのですが、詳細は <a href="https://www.google.co.jp/">こちら１</a>。問い合わせ先は<a href="mailto:[e-mail]">こちら１</a>このまま記載されてしまいます。ハイパーリンクにはならないのでしょうか？説明が不足していてすみませんがご教示ください。

[yshima1129]

.「BodyFormat = ２」の「２」が全角だからでしょうか・・・？
パット見ですが、半角の「2」にしてみてはどうでしょうか？

[koko2]

コメントありがとうございました。BodyFormat = ２に入れ直してみましたが変わりませんでした。自分のソースコードが良くないみたいです。見直してみます。