エクセル VBA メール本文に指定セルに記載されているURLをリンクとして記載する方法

お詳しい方　ご教授をお願いします。

下記のコードを組んだのですが、メールをHDML形式で本文にどうしても指定セルのＵＲＬをリンク状態で記載されませ。

例としてセルB11にURL先が記載されているという条件でどうのようにコードを組むか
アドバイスを頂けないでしょうか。

Sub sumple1_Click()

'To　抽出～メール起動------------------------------------------------------

Dim oApp As Object

Dim oMail As Object

Dim i As Long, tmpto As String

Application.ScreenUpdating = False

Set oApp = CreateObject("Outlook.Application")

Set oMail = oApp.CreateItem(0)

'宛先

For i = 2 To Cells(Rows.Count, "G").End(xlUp).row

If Range("G" & i).Value <> "" Then

If tmpto = "" Then

tmpto = Range("G" & i).Value

Else

tmpto = tmpto & "," & Range("G" & i).Value

End If

End If

Next i

If tmpto <> "" Then

With oMail

.To = tmpto

'To 抽出終わり----------------------------------------





'件名

.Subject = Range("B9").Value

'本文





'内容抽出-------------------------------------------



.Body = Range("B10").Value





.Display '表示

'.Send '送信



End With

End If

Application.ScreenUpdating = True


End Sub

質問者からの補足コメント

• 回答いただきありがとうございます。Toの宛先ですが最大５名程度を考えていたので　ＢＣＣについてはなにも考えていませんでした。今後宛先が増えるようでしたら頂いたアドバイスを参考にさせていただきます。　
  
  また、質問事項について説明不足でしたので、下記に質問事項を追加させてもらいます。
  
  現在の悩みは
  セル10に本文として下記URLをご参照ください。
  などの定型文が記載されており。
  セル11に対象のURLが記載さている条件で本文に定型文+URLリンクを表示させたいと考えています。　この併せて表示というのがなかなかうまくいかず難儀しています。

    補足日時：2022/08/08 10:01

• アドバイスありがとうございます。
  
  ご教授いただいたコードをそのまま反映させたところ本文とURLは連結して表示がされるようになったのですが、セルＢ11のURLが本文では青字（リンク状態）にどうしてもなりませんでした。
  
  連結させる際のコードをもう少し弄ればいけそうな気がしますが、色々自分なりに努力したのですが、なかなかうまくいかず・・
  もしよろしければ、不具合についてアドバイスを頂けると助かります。

    補足日時：2022/08/09 13:03

No.8 ベストアンサー 回答者： KenKen_SP 回答日時： 2022/08/10 00:39

こんばんは。

>セルＢ11のURLが本文では青字（リンク状態）にどうしてもなりませんでした。

Outlook のオプション設定で、ディフォルトのメール形式がテキストに設定してあるんだと思いますよ。
全体を再掲します。下記のソースでお試し下さい。

　# HTMLソースをVBAで書くのは面倒なので
　# リンクはOutlookにまかせてます

Sub sumple1_Click()

　　'Outlook/CreateObject 定数
　　Const olMailItem = 0　　'メール
　　'Outlook/CreateItem 定数
　　Const olFormatPlain = 1 'テキスト形式メール
　　Const olFormatHTML = 2　'HTML形式メール
　
　　'To抽出 -----------------------------------------------

　　Dim i　　　As Long
　　Dim tmpto As String

　　'宛先
　　For i = 2 To Cells(Rows.Count, "G").End(xlUp).Row
　　　　If Range("G" & i).Value <> "" Then
　　　　　　If tmpto = "" Then
　　　　　　　　tmpto = Range("G" & i).Value
　　　　　　Else
　　　　　　　　'■↓変更 アドレス区切り文字は「;」
　　　　　　　　tmpto = tmpto & ";" & Range("G" & i).Value
　　　　　　End If
　　　　End If
　　Next i

　　If Len(tmpto) = 0 Then Exit Sub '宛先がなければ終了
　　
　　'本文を作成 -------------------------------------------
　　Dim body_text As String
　　body_text = Range("B10").Value _
　　　　　　　& Range("B11").Value

　　'Outlookを起動してメール作成 --------------------------
　
　　Dim oApp　 As Object 'Outlook.Application
　　Dim oMail　As Object 'Outlook.MailItem
　　Set oApp = CreateObject("Outlook.Application")
　　Set oMail = oApp.CreateItem(olMailItem)
　　With oMail
　　　　.BodyFormat = olFormatHTML　　　'<--■追加 HTML形式
　　　　.To = tmpto　　　　　　　　　　 '宛先
　　　　.Subject = Range("B9").Value　　'件名
　　　　.Body = body_text　　　　　　　 '本文
　　　　.Display　　　　　　　　　　　　'ブレビュー
　　　　'.Send　　　　　　　　　　　　　 '送信
　　End With

　　'他アプリを操作したらオブジェクトを必ず破棄
　　'オートメーションエラーの原因になります
　
　　Set oMail = Nothing
　　Set oApp = Nothing

End Sub

この回答へのお礼

アドバイスありがとうございました。　なんとかなりそうです。

お礼日時：2022/08/10 17:44

No.7 回答者： KenKen_SP 回答日時： 2022/08/08 19:15

おおー、ごめんなさい。

投稿したのが消えたと思って同じ内容投稿しちゃいました。

No.6 回答者： KenKen_SP 回答日時： 2022/08/08 19:14

URL をリンクにするだけなら別にHTMLメール形式にする必要はなく、テキスト形式で大丈夫ですよ。

No.5 回答者： KenKen_SP 回答日時： 2022/08/08 19:11

URLリンクだけなら HTML メールである必要はありませんね。

テキスト形式でも URL はリンクになります。

補足からご質問での実現したい事の課題は、複数のセルにある値をいかに連結するかにあると判断しました。

テキストはB10またはB11セルにあるそうですが、VBAソースからはその痕跡が見られなかったので。

余談ですが、改行コード　vbNewline は　Windows だと　vbCrLf と同意です。

No.4 回答者： Qchan1962 回答日時： 2022/08/08 15:25

こんにちは

＞HTMLメールを本文にどうしても指定セルのＵＲＬをリンク状態で記載されませ。

HTML形式の例

'To 抽出終わり----------------------------------------
Dim strHTML As String
If tmpto <> "" Then
If Range("B11") <> "" Then
strHTML = Range("B10").Text & "<br>" _
& "<a href=" & Range("B11").Text & "> 参考URL</a>"
Else
strHTML = Range("B10").Text & "</a>"
End If

With oMail
'件名
.Subject = Range("B9").Value
.To = tmpto
.CC = ""
'本文
.HTMLBody = "<b>宛先各位</b>" _
& "<br><br>" _
& " 初めに" _
& "<br><br>" _
& "要件<br>" _
& strHTML _
& "<br><br>" _
& "<a href=""https://oshiete.goo.ne.jp/qa/13084470.html"">教えて!goo</a>"
'.Attachments.Add ("C:\Users\xx\添付ファイル.pdf")
.Display '表示
'.Send '送信
End With
End If


If Range("B11") <> "" Thenの条件は適当
文字列作成　（文字列　改行　リンク文字（非表示）　表示文字）
strHTML = Range("B10").Text & "<br>" _
& "<a href=" & Range("B11").Text & "> 参考URL</a>"

URLだけを表示したい場合は
strHTML = Range("B10").Text & "<br>" _
& "<a href=" & Range("B11").Text & ">" & Range("B11").Text & "</a>"

No.3 回答者： KenKen_SP 回答日時： 2022/08/08 11:28

ごめんなさい。

レイトバインドなの忘れてました。＃２の下記部分を差し替えて下さい

　　Dim oApp　 As Outlook.Application ' Object
　　Dim oMail　As Outlook.MailItem　　' Object

　　　　　↓

　　Dim oApp　As Object
　　Dim oMail　As Object

No.2 回答者： KenKen_SP 回答日時： 2022/08/08 11:25

HTML で本文を書いてない＝テキスト形式メールであるなら

→#1 ■VBA ソースについて　はスルーして下さい

＞この併せて表示というのがなかなかうまくいかず難儀しています。

単純に文字列を連結して Body に指定すれば良いと思いますよ。
改行は vbNewline です。ソース全体を少し直しました。

Sub sumple1_Click()

　　'Outlook/CreateObject 定数
　　Const olMailItem = 0　　'メール
　　'Outlook/CreateItem 定数
　　Const olFormatPlain = 1 'テキスト形式メール
　　Const olFormatHTML = 2　'HTML形式メール
　　
　　'To抽出 -----------------------------------------------

　　Dim i　　　As Long
　　Dim tmpto　As String

　　'宛先
　　For i = 2 To Cells(Rows.Count, "G").End(xlUp).Row
　　　　If Range("G" & i).Value <> "" Then
　　　　　　If tmpto = "" Then
　　　　　　　　tmpto = Range("G" & i).Value
　　　　　　Else
　　　　　　　　tmpto = tmpto & "," & Range("G" & i).Value
　　　　　　End If
　　　　End If
　　Next i

　　If Len(tmpto) = 0 Then Exit Sub ’宛先がなければ終了

　　'Outlookを起動してメール作成 --------------------------
　　
　　Dim oApp　 As Outlook.Application ' Object
　　Dim oMail　As Outlook.MailItem　　' Object
　　Set oApp = CreateObject("Outlook.Application")
　　Set oMail = oApp.CreateItem(olMailItem)

　　'B10セル、B11セルの内容を連結して本文作成
　　Dim body_text As String
　　body_text = Range("B10").Value & vbNewLine _
　　　　　　　& Range("B11").Value
　　
　　With oMail
　　　　.To = tmpto　　　　　　　　　　 '宛先
　　　　.Subject = Range("B9").Value　　'件名
　　　　.Body = body_text　　　　　　　 '本文
　　　　.Display　　　　　　　　　　　　'ブレビュー
　　　　'.Send　　　　　　　　　　　　　 '送信
　　End With

　　'重要
　　'他アプリを操作したらオブジェクトを必ず破棄
　　'オートメーションエラーの原因になります
　　
　　Set oMail = Nothing
　　Set oApp = Nothing

End Sub

No.1 回答者： KenKen_SP 回答日時： 2022/08/08 09:26

こんにちは。

下記ポイントを確認してみて下さい。

■Outlook 側の設定はどうなっていますか？
https://support.microsoft.com/ja-jp/office/f361c …

■一斉配信は、BCC欄（またはCC欄）を通常使います。
　配信数によっては、、ですが、TO欄で大丈夫？
　(例）BCC欄を使う場合　 oMail.BCC = tmpto

■VBA ソースについて
下記で試してみて下さい。

'内容抽出-------------------------------------------
.BodyFormat = 2　　　　　　　　　'追加 2:olFormatHTML
'.Body = Range("B10").Value　　　　'下行に訂正
.HTMLBody = Range("B10").Value　'B10? B11セル？

■最大発信数について
　本件の目的、何件のメール送信になるのかが明記されてません。
　メールプロバイダーは１日で送れるメール最大数を定めています。
　これは迷惑メール防止、サーバーへの過度な負荷予防の観点から。
　この点、問題はありませんか？