VBA Outlook代码无法生成新MailItem，发送旧邮件问题求助

问题描述 #

执行以下VBA代码发送邮件时，工作机始终发送旧版本邮件，内容无法更新。同一代码在其他机器运行正常，能发送全新邮件；更新代码后工作机依旧发送旧邮件，疑似缓存相关问题。

原VBA代码 #

Private Sub CommandButton16_Click()
Dim EmailApp As Outlook.Application
Dim EmailItem As Outlook.MailItem
Set EmailApp = New Outlook.Application

Dim EmailAddress As String
Dim EmpName As String
Dim ProvName As String
Dim PayMonth As String
Dim Filename As String
Dim Filepath As String
Dim FileExists As String
Dim Subject As String
Dim Source As String
Dim AltEmail As String
Dim ExtraMsg As String
Dim i As Long


'Loop through and get email address and names
    i = 2
    PayMonth = TextBox6.Value
    AltEmail = TextBox7.Value
    ExtraMsg = TextBox8.Value
    
Do While Worksheets("Provider Template").Cells(i, 1).Value <> ""
    ProvName = Worksheets("Provider Template").Cells(i, 1).Value
    EmpName = Worksheets("Provider Template").Cells(i, 11).Value
    If AltEmail = "" Then EmailAddress = Worksheets("Provider Template").Cells(i, 20).Value Else EmailAddress = AltEmail
    Filename = ProvName & " " & PayMonth
    Filepath = ThisWorkbook.Path & "\Remittance PDFs\"
    Source = Filepath & Filename & ".pdf"
    Subject = "Monthly Remittance Advice for" & " " & ProvName & " - " & PayMonth
    FileExists = Dir(Source)
    If FileExists = "" Then GoTo Lastline Else GoTo SendEmail
SendEmail:
    Set EmailItem = EmailApp.CreateItem(olMailItem)
    With EmailItem
    EmailItem.To = EmailAddress
    EmailItem.CC = "******************"
    EmailItem.Subject = Subject
    EmailItem.HTMLBody = "<html><body><p>Here is the tax invoice and calculation sheet for " & ProvName & ".</p><p>" & ExtraMsg & "</p><p>Kind regards, ******</p><p>****** ******</p><p>Practice Manager</p></body></html>"
    EmailItem.Attachments.Add Source
    EmailItem.Send
    End With
    GoTo Lastline
Lastline:
    i = i + 1
Loop
End Sub

排查与解决步骤 #

1. 清理Outlook缓存 #

• 关闭Outlook，打开文件资源管理器，输入%LOCALAPPDATA%\Microsoft\Outlook，删除目录下的.ost或.pst缓存文件（操作前请备份重要邮件数据）
• 重启Outlook，系统会自动重建缓存文件

2. 重置VBA项目缓存 #

• 打开Excel，按Alt+F11进入VBA编辑器
• 右键点击当前工作簿的VBA项目，选择导出文件，备份代码模块
• 删除原模块，重新导入备份的模块
• 保存工作簿并重启Excel

3. 优化代码避免对象残留 #

代码中未显式释放邮件对象可能导致缓存残留，修改后的代码如下：

Private Sub CommandButton16_Click()
Dim EmailApp As Outlook.Application
Dim EmailItem As Outlook.MailItem
Set EmailApp = New Outlook.Application

Dim EmailAddress As String
Dim EmpName As String
Dim ProvName As String
Dim PayMonth As String
Dim Filename As String
Dim Filepath As String
Dim FileExists As String
Dim Subject As String
Dim Source As String
Dim AltEmail As String
Dim ExtraMsg As String
Dim i As Long


'Loop through and get email address and names
    i = 2
    PayMonth = TextBox6.Value
    AltEmail = TextBox7.Value
    ExtraMsg = TextBox8.Value
    
Do While Worksheets("Provider Template").Cells(i, 1).Value <> ""
    ProvName = Worksheets("Provider Template").Cells(i, 1).Value
    EmpName = Worksheets("Provider Template").Cells(i, 11).Value
    If AltEmail = "" Then EmailAddress = Worksheets("Provider Template").Cells(i, 20).Value Else EmailAddress = AltEmail
    Filename = ProvName & " " & PayMonth
    Filepath = ThisWorkbook.Path & "\Remittance PDFs\"
    Source = Filepath & Filename & ".pdf"
    Subject = "Monthly Remittance Advice for" & " " & ProvName & " - " & PayMonth
    FileExists = Dir(Source)
    
    If FileExists <> "" Then
        Set EmailItem = EmailApp.CreateItem(olMailItem)
        With EmailItem
            .To = EmailAddress
            .CC = "******************"
            .Subject = Subject
            .HTMLBody = "<html><body><p>Here is the tax invoice and calculation sheet for " & ProvName & ".</p><p>" & ExtraMsg & "</p><p>Kind regards, ******</p><p>****** ******</p><p>Practice Manager</p></body></html>"
            .Attachments.Add Source
            .Send
        End With
        ' 显式释放邮件对象
        Set EmailItem = Nothing
    End If
    
    i = i + 1
Loop
' 释放Outlook应用对象
Set EmailApp = Nothing
End Sub

4. 清理Excel缓存文件 #

• 关闭Excel，删除工作簿所在目录下的.xlb（Excel界面设置缓存）和.tmp临时文件
• 右键点击工作簿，检查属性，确保未勾选只读选项

内容的提问来源于stack exchange，提问作者Jim G-GP