发送 Outlook 电子邮件的 Excel 宏不会发送

Question

我有这个代码，它使用 Excel 工作表创建带有附件的 Outlook 电子邮件。它正确创建电子邮件并且 Display 工作正常，但我无法让 SendUsingAccount 发送电子邮件（在 Display 后手动发送每封电子邮件工作正常）。

有人可以指出错误吗？

非常感谢！

Sub Send_Files()

    Dim Sht As Worksheet
    Dim olApp As Object, olMail As Object, olRecip As Object, olAtmt As Object
    Dim iRow As Long
    Dim Recip As String, Subject As String, Atmt As String
    Dim OutApp As Outlook.Application
    Dim OutMail As Outlook.MailItem
    Dim OutAccount As Outlook.Account
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(olMailItem)  
    Set OutAccount = OutApp.Session.Accounts.Item(2)
   
Application.EnableEvents = False
Application.ScreenUpdating = False

   iRow = 2

   Set olApp = CreateObject("Outlook.Application")
   Set Sht = ThisWorkbook.Worksheets("Mailinglist_1")

   Do Until IsEmpty(Sht.Cells(iRow, 1))

      Recip = Sht.Cells(iRow, 2).Value
      Subject = Sht.Cells(iRow, 4).Value
      Atmt = Sht.Cells(iRow, 3).Value 

      Set olMail = olApp.CreateItem(0)

      With olMail
            Set olRecip = .Recipients.Add(Recip)
            Set olMail.SendUsingAccount = OutAccount
            
            .Subject = "Test 2021"
            .Body = "Dear " & Sht.Cells(iRow, 1).Value & "," & vbNewLine & vbNewLine & _
                "Text" & vbNewLine & _
                "Text" & vbNewLine & _
                "The Team"

            olRecip.Resolve
            
            Set olAtmt = .Attachments.Add(Atmt)
            Set .SendUsingAccount = OutAccount

      .Send
      End With

      iRow = iRow + 1

   Loop

   Set olApp = Nothing

Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub