差し込み情報付きドラフトメールを作成

' 指定されたテンプレート文字列内のプレースホルダーを実際のデータで置き換える関数
Function ReplacePlaceholders(ByVal template As String, ByVal ws As Worksheet, ByVal rowNum As Long) As String
' 置き換えるプレースホルダーの配列
Dim placeholders As Variant
placeholders = Array("{宛名}", "{テキスト1}", "{テキスト2}", "{テキスト3}")

Dim i As Integer
' プレースホルダーを実際のセルのデータで置き換える
For i = LBound(placeholders) To UBound(placeholders)
template = Replace(template, placeholders(i), ws.Cells(rowNum, i + 1).Value)
Next i

' 置き換え後のテンプレートを返す
ReplacePlaceholders = template
End Function

' メールの下書きを作成するメインサブルーチン
Sub CreateEmailDraftsWithSender()
Dim wsMail As Worksheet, wsTemplate As Worksheet
' メール送信とメールテンプレートのシートを設定
Set wsMail = ThisWorkbook.Sheets("メール送信")
Set wsTemplate = ThisWorkbook.Sheets("メールテンプレート")

Dim OutApp As Object
' Outlookアプリケーションのオブジェクトを作成し、ログイン
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon

Dim lastRow As Long
' メール送信シートの最終行を取得
lastRow = wsMail.Cells(wsMail.Rows.Count, "A").End(xlUp).Row

Dim i As Long
' 各行をループし、条件に合致する行でメール下書きを作成
For i = 2 To lastRow
If wsMail.Cells(i, 5).Value = "メールを送る" Then
CreateDraft OutApp, wsMail, wsTemplate, i
End If
Next i

' 完了メッセージボックスを表示
MsgBox "メールの下書きを作成しました", vbInformation
End Sub

' メールの下書きを作成するサブルーチン
Sub CreateDraft(ByVal OutApp As Object, ByVal wsMail As Worksheet, ByVal wsTemplate As Worksheet, ByVal rowNum As Long)
On Error GoTo ErrorHandler
' メールテンプレートから件名と本文を取得し、プレースホルダーを置き換え
Dim mailSubject As String, mailBody As String
mailSubject = ReplacePlaceholders(wsTemplate.Cells(1, 2).Value, wsMail, rowNum)
mailBody = ReplacePlaceholders(wsTemplate.Cells(2, 2).Value, wsMail, rowNum)

Dim OutMail As Object
' Outlookメールアイテムの作成と設定
Set OutMail = OutApp.CreateItem(0)
With OutMail
' F列（差出人）、G列（To）、

H列（CC）、I列（BCC）から情報を取得し設定
.SentOnBehalfOfName = wsMail.Cells(rowNum, 6).Value ' F列（差出人）
.To = wsMail.Cells(rowNum, 7).Value ' G列（To）
.CC = wsMail.Cells(rowNum, 8).Value ' H列（CC）
.BCC = wsMail.Cells(rowNum, 9).Value ' I列（BCC）
.Subject = mailSubject ' 件名
.Body = mailBody ' 本文
.Save ' 下書きとして保存
End With

' Outlookメールアイテムのオブジェクトを解放
Set OutMail = Nothing
Exit Sub

ErrorHandler:
' エラー発生時の処理
MsgBox "エラーが発生しました: " & Err.Description, vbCritical
' オブジェクトを解放
Set OutMail = Nothing
End Sub