未发送副本草稿关闭时自动删除的Outlook VBA实现问题

我有一些带复制、打开按钮的草稿邮件，只需填写少量内容就能发送。需求是：保留原始草稿，但关闭未发送的副本邮件时自动删除它。目前使用MailItem的Close事件，但在该子程序中无法实现删除操作，尝试多种方法均未解决，求可行方案。

模块中的代码 #

Dim itmevt As New CMailItemEvents
Public olMail As Variant
Public olApp As Outlook.Application
Public olNs As NameSpace
Public Fldr As MAPIFolder

Sub TeamcenterWEBAccount()

Dim i As Integer
Dim olMail As Outlook.MailItem

Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderDrafts)

For Each olMail In Fldr.Items
    If InStr(olMail.Subject, "New account") <> 0 Then
        Set NewItem = olMail.Copy
        olMail.Display
        Set itmevt.itm = olMail
        Exit Sub
    End If
Next olMail

End Sub

CMailItemEvents类模块中的代码 #

Option Explicit
Public WithEvents itm As Outlook.MailItem

Private Sub itm_Close(Cancel As Boolean)
    Dim blnSent As Boolean
    On Error Resume Next
    blnSent = itm.Sent
    If blnSent = False Then
        itm.DeleteAfterSubmit = True
    Else
       ' do
End Sub

原代码存在两个核心问题：一是绑定了原始草稿的Close事件而非副本的，二是DeleteAfterSubmit属性仅对已提交的邮件生效，关闭未发送邮件时无法触发删除。以下是修正后的实现：

修改后的模块代码 #

Dim itmevt As New CMailItemEvents
Public olApp As Outlook.Application
Public olNs As NameSpace
Public Fldr As MAPIFolder

Sub TeamcenterWEBAccount()
    Dim olMail As Outlook.MailItem
    Dim newMailCopy As Outlook.MailItem ' 存储副本邮件
    
    Set olApp = New Outlook.Application
    Set olNs = olApp.GetNamespace("MAPI")
    Set Fldr = olNs.GetDefaultFolder(olFolderDrafts)
    
    For Each olMail In Fldr.Items
        If InStr(olMail.Subject, "New account") <> 0 Then
            Set newMailCopy = olMail.Copy ' 复制原始草稿得到副本
            newMailCopy.Display ' 打开副本进行编辑
            Set itmevt.itm = newMailCopy ' 绑定副本的Close事件
            Exit Sub
        End If
    Next olMail
End Sub

修改后的类模块代码 #

Option Explicit
Public WithEvents itm As Outlook.MailItem

Private Sub itm_Close(Cancel As Boolean)
    Dim blnSent As Boolean
    
    ' 启用错误处理，避免意外报错
    On Error GoTo ErrorHandler
    
    blnSent = itm.Sent
    
    ' 若邮件未发送，直接删除副本
    If Not blnSent Then
        itm.Delete
    End If
    
ExitSub:
    Exit Sub
ErrorHandler:
    MsgBox "删除未发送邮件时出错: " & Err.Description, vbExclamation
    Resume ExitSub
End Sub

关键修改说明 #

• 操作对象切换为副本：不再打开原始草稿，而是打开复制后的副本，确保原始草稿始终保留
• 绑定副本的事件：将事件绑定到副本邮件，而非原始草稿，保证删除操作只影响副本
• 直接删除未发送邮件：替换无效的DeleteAfterSubmit，在Close事件中直接调用itm.Delete删除未发送的副本
• 增加错误处理：捕获删除过程中的异常，提升稳定性

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