无法发送来自草稿的已保存电子邮件

Question

我正在尝试使用excel数据创建电子邮件草稿并将收件人添加到密件抄送中，我可以使用以下代码创建草稿，但是如果尝试从Outlook草稿文件夹发送电子邮件，操作失败会出现错误。 / p>

我不确定Outlook格式是否正确或缺少任何流程。

Sub SendMultipleEmails()

Dim Mail_Object, OutApp As Object
Dim ws As Worksheet:
Dim arr() As Variant
Dim Pth As String
Dim file_name As String
Dim Month As String


Sheets("Report").UsedRange.ClearContents
Month = Sheets("Macro").Range("C5")
file_name = Sheets("Macro").Range("C4")
Pth = Sheets("Macro").Range("C3").Value
Sheets("Data").Select
Set ws = ActiveSheet
LastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row

ws.Sort.SortFields.Clear
ws.Sort.SortFields.Add Key:=ws.Range("I2:I" & LastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ws.Sort
    .SetRange ws.UsedRange
    .Header = False
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

arr = ws.Range("I2:I" & LastRow)

Set Mail_Object = CreateObject("Outlook.Application")

first = 2

For i = LBound(arr) To UBound(arr)


    If i = UBound(arr) Then GoTo YO
    If arr(i + 1, 1) = arr(i, 1) Then
                first = WorksheetFunction.Min(first, i + 1)
    Else
YO:
    Set OutApp = Mail_Object.CreateItem(0)

    With OutApp
         .Subject = "My Acc Holding Holding")
         .Body = "Hello" & vbNewLine _
                & vbNewLine _
                & "Please find the attached Acc Holding"

         .Display
         bc = ws.Range("F" & i + 1).Value
     For j = first To i
        bc = bc & ";" & ws.Range("F" & j).Value
     Next
     .BCC = bc
     first = i + 2

      .Save


         first = i + 2

    End With
    End If

Next



End Sub