Option Explicit
' Windows APIのSleep関数を宣言
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)

Sub 一斉メール送信()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim ws As Worksheet
    Dim i As Long
    Dim cnt As Long
    Dim emailAddress As String
    Dim bccAddress As String
    Dim subject As String
    Dim body As String
    Dim strQr As String

    ' 件名とBcc
    subject = "アンケートへのご協力ありがとうございました"
    bccAddress = "testtesttest@gmail.com"    ' Bccのメールアドレス

    ' シート参照
    Set ws = ThisWorkbook.Sheets("送付先")

    ' Outlookのアプリケーションを作成
    Set OutApp = CreateObject("Outlook.Application")

    ' 2行目から最大1000行目までループ
    For i = 2 To 1000
        If ws.Cells(i, 2).Value = "" Then Exit For

        If ws.Cells(i, 2).Value <> "" And ws.Cells(i, 5).Value = "" Then
            emailAddress = ws.Cells(i, 3).Value
            strQr = ws.Cells(i, 4).Value
            body = strBody(ws.Cells(i, 2).Value)
            body = Replace(body, "★★URL★★", strQr)

            ' メール作成と送信
            Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .To = emailAddress
                .Subject = subject
                .Body = body
                .BCC = bccAddress
                .Send
            End With
            Set OutMail = Nothing

            ' 送信済み記録
            ws.Cells(i, 5).Value = "済 " & Format(Now, "yyyy/mm/dd hh:nn:ss")

            cnt = cnt + 1
            If cnt = 400 Then Exit For

            ' 3秒待機
            Sleep 3000
        End If
    Next i

    Set OutApp = Nothing
    MsgBox "メール送信が完了しました。"
End Sub