Question

发送大量电子邮件时，大约180封电子邮件告诉我MS Access无法再打开任何记录后，在“ DoCmd.OutputTo”行上收到错误消息。如果增加附件，则我会收到错误，具体取决于我添加到电子邮件中的附件数量。

我相信这是因为MS Access在输出电子邮件后没有删除记录ID。我试图解决此问题的方法是在移至下一个记录集之前添加“ 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

Ms Access-发送大量电子邮件时出错

0 个答案: