Access通过Outlook自动化发邮件时资源耗尽问题求助

问题背景 #

我有一个MS Access应用程序，通过Outlook自动化发送邮件，使用的VBA代码基本未修改某教程中「Create an email with Outlook-Automation」标题下的内容。

运行数天、发送100-1000封邮件给不同收件人后，Outlook会挂起，导致Access中其他待执行代码暂停，同时弹出3-5个资源耗尽提示框：

已尝试每次发送前终止Outlook进程，但Outlook通常处于关闭状态——代码会打开Outlook、发送后关闭，且所有对象在代码结束时都已关闭并设为Nothing。

当前PC配置充足，运行64位Office 365，因托管24/7使用的SQL Server，无法定时重启。

现有代码 #

以下是稍作修改的VBA代码：

Public Function funSendEmail()
Dim EmailType As String
Dim myMail As Object
Dim myOutlApp As Object
Const olMailItem = 0

    EmailType = EmailApp()

    If EmailType = "OutlookOpen" Then
        Set myOutlApp = GetObject(, "Outlook.Application")
    ElseIf EmailType = "OutlookClosed" Then
        Set myOutlApp = CreateObject("Outlook.Application")
    End If
   
    Set myMail = myOutlApp.CreateItem(olMailItem)

    With myMail
        .To = "test@me.com"
        .Subject = "Test"
        .HTMLBody = "Test Message"
        .Send
    End With
 
   If EmailType = "OutlookClosed" Then
        myOutlApp.Quit
    End If

    Set myMail = Nothing
    Set myOutlApp = Nothing
End Function

注：EmailApp()函数用于检查Outlook是否已打开，以决定初始化方式及后续处理逻辑

解决方案建议 #

1. 避免频繁启停Outlook #

当前代码每次发送都可能启停Outlook，频繁创建销毁进程会积累资源碎片。建议保持Outlook长期运行，不再每次发送后调用Quit：

• 初始化时统一用GetObject尝试获取现有实例，失败再创建新实例
• 全程不主动关闭Outlook，让系统或用户管理其生命周期

修改后核心逻辑：

On Error Resume Next
Set myOutlApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
    Set myOutlApp = CreateObject("Outlook.Application")
End If
On Error GoTo 0

' 发送邮件逻辑...

' 不再调用Quit，仅释放对象
Set myMail = Nothing
Set myOutlApp = Nothing

2. 增加邮件发送间隔与错误处理 #

短时间内批量发送邮件会触发Outlook资源过载，建议：

• 每发送1封邮件后增加DoEvents释放CPU资源
• 批量发送时插入1-2秒延迟（用Sleep函数，需声明API）
• 添加错误捕获，避免异常导致对象未正确释放

示例延迟代码：

' 声明API（需放在模块顶部）
#If VBA7 Then
    Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
#Else
    Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

' 发送后延迟1秒
Sleep 1000
DoEvents

3. 清理Outlook缓存与自动存档 #

• 定期清理已发送邮件文件夹，开启自动存档减少本地数据量
• 在Outlook选项中禁用不必要的加载项，减轻后台资源占用

4. 使用直接SMTP发送替代Outlook自动化 #

若上述方案无效，可绕过Outlook，直接用SMTP协议发送邮件，彻底避免Outlook资源问题。示例VBA代码：

Public Sub SendEmailViaSMTP()
    Dim objMsg As Object
    Set objMsg = CreateObject("CDO.Message")
    
    With objMsg
        .To = "test@me.com"
        .Subject = "Test"
        .HTMLBody = "Test Message"
        .From = "your_email@domain.com"
        
        ' 配置SMTP服务器
        With .Configuration.Fields
            .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.office365.com"
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 587
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
            .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "your_email@domain.com"
            .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "your_app_password"
            .Update
        End With
        
        .Send
    End With
    
    Set objMsg = Nothing
End Sub

注：Office 365需启用应用密码，或使用现代认证方式

内容的提问来源于stack exchange，提问作者riley3131