Ms Access - ошибка при отправке массовых писем

Question

При отправке массовых писем я получаю сообщение об ошибке в строке «DoCmd.OutputTo» после примерно 180 писем, в котором говорится, что MS Access больше не может открывать записи.Если я увеличу вложения, я получу ошибку раньше, в зависимости от того, сколько вложений я добавлю в электронное письмо.

Я полагаю, это потому, что MS Access не сбрасывает идентификатор записи после вывода электронной почты.Моя попытка решить эту проблему состояла в том, чтобы добавить: «Recordset.Close» до перехода к следующему набору записей.К сожалению, это не влияет на количество сообщений, которые я могу отправить до получения ошибки.

Кто-нибудь знает способ исправить эту ошибку, чтобы я мог отправлять 400+ электронных писем без необходимости закрывать и снова открывать базу данных.Моя причина для исправления этой ошибки - потому что я хотел бы установить это в планировщик задач, чтобы он мог запускаться автоматически ранним утром и не влиял на производительность.

Мой код выглядит следующим образом:

   Option Explicit
   Sub SendEmailXLS()
   Dim appExcel As Excel.Application
   Dim objActiveWkb As Object
   Dim ActiveWorkbook As Object
   Dim objActiveSheet As Object
   Dim objActiveChart As Object

  'prevenet 429 error, if outlook not open


DoCmd.OpenReport " XLS", acViewReport, WhereCondition:="EmailAddress='" & Me.User_Login & "'"
DoCmd.OutputTo ObjectType:=acOutputReport, ObjectName:="XLS", OutputFormat:=acFormatXLS, Outputfile:=" "

Set appExcel = New Excel.Application
appExcel.Visible = True
appExcel.Workbooks.Open ("XLS.xls")

 Set objActiveWkb = appExcel.Application.ActiveWorkbook
 Set objActiveSheet = objActiveWkb.ActiveSheet
 Set objActiveChart = objActiveWkb.ActiveChart
 With objActiveWkb

.Worksheets(1).Cells.Select
.Worksheets(1).Columns("A:AH").Font.Size = 8
.Worksheets(1).Rows(1).Font.Bold = True
.Worksheets(1).Columns("A:AH").Font.Name = "Subway Footlong Office"
.Worksheets(1).Columns("A:AH").HorizontalAlignment = -4108
 ChDir _
    "XLS"
objActiveWkb.SaveAs FileName:= _
    "XLSX.xlsx" _
    , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End With
objActiveWkb.Close savechanges:=True
appExcel.Application.Quit
Set objActiveWkb = Nothing: Set appExcel = Nothing
DoCmd.Close acReport, " XLSX", acSaveNo

    Dim oApp As New Outlook.Application
    Dim oEmail As Outlook.MailItem
    Set oEmail = oApp.CreateItem(olMailItem)
   oEmail.To = [User_Login]
 oEmail.CC = "xxx.com"
 oEmail.BCC = "xxx.com"
 oEmail.Subject = "XLS " & Date
 oEmail.Body = "."
 oEmail.Attachments.Add "XLSX.xlsx"
 oEmail.Send



 DoCmd.Close acReport, " XLS", acSaveNo


End Sub

Private Sub Command21_Click()

Do While Not Recordset.EOF
Call Email_Click
Recordset.MoveNext
Loop

End Sub

Private Sub Email_Click()

Call SendEmailXLS
Call DeleteFileName
End Sub


 Function Fileexists(fname) As Boolean
 If Dir(fname) <> "" Then _
 Fileexists = True _
 Else: Fileexists = False
 End Function

 Sub DeleteFile(ByVal FileToDelete As String)
 If Fileexists(FileToDelete) Then 'See above
  ' First remove readonly attribute, if set
  SetAttr FileToDelete, vbNormal
  ' Then delete the file
  Kill FileToDelete
  End If
  End Sub

  Sub DeleteFileName()
  DeleteFile ("XLS.xls")
  End Sub

  Private Sub Form_Load()

  Do While Not Recordset.EOF
  Call Email_Click
  Recordset.Close
  Recordset.MoveNext
  Loop

  End Sub