【ExcelVBA】Outlookメールの作成から一括送信まで

Option Explicit
Sub 一括送信()
    Dim mybook As Workbook
    Dim i As Long
    Dim lngFileCount As Long
    Dim m As Long
    Dim Msg As String
    Dim mladd As String
    Dim mlcc As String
    Dim mlbcc As String

    Set mybook = ThisWorkbook
    With mybook
        '最初の列のファイル数をカウント
        lngFileCount = Application.CountA(.Sheets("送信設定").Range("C6:C2000"))
        On Error GoTo er

        Call マクロ開始

        i = 6   'ループカウンター初期値（セル６から始まるから）
        Do Until i > 2000   'とりあえず２０００で
            If lngFileCount < 0 Then Exit Do
            If .Sheets("送信設定").Cells(i, 1) = 0 Then GoTo nextloop
            lngFileCount = lngFileCount - 1
            With .Sheets("Address")
                mladd = .Cells(i, 3).Value　'宛先
                mlcc = .Cells(i, 4).Value   'CCのアドレスを３つセット
                mlcc = mlcc & " ; " & .Cells(i, 5).Value
                mlcc = mlcc & " ; " & .Cells(i, 6).Value
                mlbcc = .Cells(i, 7).Value　'BCCのアドレス
            End With
            '次の処理へ
            Call sendAddMail(i, mladd, mlcc, mlbcc)
nextloop:
            i = i + 1   'カウンターを増やす
        Loop
    End With

    Call マクロ終了
    MsgBox "一括送信が完了しました！", vbInformation, "一括送信終了メッセージ"
    Exit Sub
er:
'エラー処理
    Msg = "エラー番号 " & Str(Err.Number) & Err.Source & _
          " でエラーが発生しました。" & Chr(13) & Err.Description
    MsgBox Msg, , "エラー", Err.HelpFile, Err.HelpContext
    Call マクロ終了
End Sub

'添付ファイルやメール本体をセットする
Sub sendAddMail(i As Long, mladd As String, mlcc As String, mlbcc As String)
    Dim oApp As New Outlook.Application
    Dim oItem As Outlook.MailItem
    Dim mybook As Workbook
    Dim mysh As Worksheet
    Dim strFilename As String
    Dim strFoldName As String
    Dim ret As Long
    Dim n As String
    Dim chk As Long
        
    Set mybook = ThisWorkbook
    Set mysh = mybook.Sheets("Mail設定")
        
    Set oItem = oApp.CreateItem(olMailItem)

    With oItem
        mysh.Range("C2") = mybook.Sheets("Address").Cells(i, 1)
        mysh.Range("B2:D2").Calculate
        .To = mladd     '送信先アドレス
        .CC = mlcc      'CC
        .BCC = mlbcc    'BCC
        '代理送信の場合設定【設定しない場合個人アドレスからの送信になる】
        .SentOnBehalfOfName = mysh.Range("F2")
        .Subject = mysh.Range("B1").Text     '件名
        .Importance = mysh.Range("H2") 'olImportanceHigh  '重要度High=2,Low=0,Normal=1
        '送信方法の確認
        chk = mysh.Range("J2").Value
        
        '添付ファイルをセット
        Dim k As Long
        For k = 3 To 7
            strFoldName = Cells(4, k) & "\"
            n = mybook.Sheets("送信設定").Cells(i, k)
            If n = "" Then GoTo nextloop
            If Dir(strFoldName, vbDirectory) = "" Then
                ret = MsgBox("ファイル設定に誤りがあります。確認後に再実行してください。", _
                                    vbYes, "ファイル一括送信"): Exit Sub
            End If
            strFilename = strFoldName & n       'フルパスのファイル名
             
             '指定ファイルが存在しない場合
            If Dir(strFilename) = "" Then
                ret = MsgBox(n & " は存在しません。このファイルを飛ばして続行しますか。", _
                vbYesNo, "なんでもデータ取得システム")
                If ret = vbYes Then
                    GoTo nextloop
                Else: Exit Sub
                End If
            End If
            
            .Attachments.Add strFilename
nextloop:
        Next k
        
        .BodyFormat = olFormatHTML 'olFormatPlainからHTML形式
        '編集のため一旦表示する
        .Display
    End With
    
    '表示後に本文データをコピペする
    Dim objDoc As Object
    'OutlookへWordEditorでデータを送る（貼る）
    Set objDoc = oApp.ActiveInspector.WordEditor

    mysh.Range("B2:B5").Copy
    With objDoc
        .Windows(1).Selection.Paste
        .Application.Selection.HomeKey Unit:=6 'wdStory 6=文頭に移動
    End With
    Application.CutCopyMode = False

    With oItem
        '送信方法分岐
        Select Case chk
            '画面表示せずに送信する場合は、
            Case 0: .Send
            '下書きに保存する場合は、
            Case 2: '.Save
                    .Close olSave
            '未選択の場合は画面確認にしておく
            Case Else: '.Display
                If chk = 1 Then
                    ret = MsgBox("メールを確認してから送信してください！" _
                            & vbCrLf & "継続しますか？（Cancelで中止）", _
                            vbOKCancel + vbExclamation, "メール確認")
                    If ret = vbCancel Then
                        Call マクロ終了
                        End
                    End If
                ElseIf chk = 2 Then
                End If
        End Select
    End With
    
    Set objDoc = Nothing
    Set oItem = Nothing
    Set oApp = Nothing
    Set mysh = Nothing
    Set mybook = Nothing
    
End Sub