Excel宏：使用EmailItem.Display时如何保留附件筛选并清除文件筛选

方案1：复制筛选内容到临时工作簿（最稳妥） #

核心思路是把筛选后的内容单独存成临时文件作为附件，原文件的筛选操作和附件完全隔离，彻底避免Outlook更新附件的问题。

步骤：

• 对目标工作表执行筛选
• 把筛选后的可见内容复制到新工作簿
• 保存临时工作簿到系统临时目录
• 将临时文件添加为邮件附件并显示邮件
• 关闭临时工作簿，清除原工作表的筛选
• 可选：延迟删除临时文件（避免Outlook占用文件）

VBA代码示例：

Sub SendFilteredSheetAndClear()
    Dim ws As Worksheet
    Dim tempWB As Workbook
    Dim tempPath As String
    Dim olApp As Object
    Dim olMail As Object
    
    ' 绑定当前活动工作表
    Set ws = ActiveSheet
    
    ' 执行你的筛选逻辑（这里示例按A列筛选"指定类别"，替换成你的实际筛选条件）
    ws.Range("A1").AutoFilter Field:=1, Criteria1:="指定类别"
    
    ' 创建新的临时工作簿
    Set tempWB = Workbooks.Add
    ' 复制筛选后的可见单元格到临时工作簿
    ws.UsedRange.SpecialCells(xlCellTypeVisible).Copy tempWB.Sheets(1).Range("A1")
    tempWB.Sheets(1).Name = ws.Name ' 保持工作表名称一致
    
    ' 生成临时文件路径（系统临时目录+时间戳避免重名）
    tempPath = Environ("TEMP") & "\筛选后文件_" & Format(Now(), "YYYYMMDDHHMMSS") & ".xlsx"
    ' 保存临时文件
    tempWB.SaveAs Filename:=tempPath, FileFormat:=xlOpenXMLWorkbook
    ' 关闭临时工作簿，释放文件占用
    tempWB.Close SaveChanges:=False
    
    ' 创建Outlook邮件
    Set olApp = CreateObject("Outlook.Application")
    Set olMail = olApp.CreateItem(0)
    With olMail
        .To = "收件人邮箱@你的域名.com" ' 替换成实际收件人
        .Subject = "【筛选后数据】指定类别内容"
        .Body = "您好，附件是筛选后的指定类别数据，请查收。"
        .Attachments.Add tempPath ' 添加临时文件作为附件
        .Display ' 弹出邮件窗口让用户手动发送
    End With
    
    ' 清除原工作表的筛选
    ws.AutoFilterMode = False
    
    ' 可选：2分钟后自动删除临时文件（避免残留）
    Application.OnTime Now() + TimeValue("00:02:00"), "DeleteTempFile", Argument:=tempPath
End Sub

' 用于删除临时文件的辅助宏
Sub DeleteTempFile(tempPath As String)
    On Error Resume Next ' 忽略文件被占用的错误
    Kill tempPath
    On Error GoTo 0
End Sub

方案2：监听Outlook发送事件（精准触发） #

通过监听Outlook的邮件发送事件，等用户手动点击发送按钮后，再自动清除原Excel文件的筛选，精准同步操作时机。

注意：需要在Excel中引用Outlook对象库（打开VBA编辑器→工具→引用→勾选「Microsoft Outlook xx.x Object Library」）

VBA代码示例：

' 声明全局对象，用于监听Outlook事件
Public WithEvents olApp As Outlook.Application
Public targetWS As Worksheet

Sub SendWithEventTrigger()
    Dim olMail As Outlook.MailItem
    
    ' 绑定需要筛选的工作表
    Set targetWS = ActiveSheet
    ' 执行筛选逻辑
    targetWS.Range("A1").AutoFilter Field:=1, Criteria1:="指定类别"
    
    ' 初始化Outlook应用
    Set olApp = New Outlook.Application
    ' 创建邮件
    Set olMail = olApp.CreateItem(olMailItem)
    With olMail
        .To = "收件人邮箱@你的域名.com"
        .Subject = "筛选后数据"
        .Body = "请查看附件中的筛选内容。"
        .Attachments.Add ActiveWorkbook.FullName ' 添加原文件作为附件
        .Display ' 弹出邮件窗口
    End With
End Sub

' 当Outlook发送邮件时触发的事件
Private Sub olApp_ItemSend(ByVal Item As Object, Cancel As Boolean)
    ' 清除原工作表的筛选
    targetWS.AutoFilterMode = False
    ' 释放全局对象
    Set olApp = Nothing
    Set targetWS = Nothing
End Sub

方案3：延迟清除筛选（简易应急版） #

如果不想搞复杂的逻辑，可让宏暂停一段时间，给用户留出发送邮件的时间，之后自动清除筛选。缺点是时间不好把控，用户如果超时未发送，筛选会被提前清除。

VBA代码示例：

Sub SendAndDelayClear()
    Dim olApp As Object
    Dim olMail As Object
    
    ' 执行筛选
    ActiveSheet.Range("A1").AutoFilter Field:=1, Criteria1:="指定类别"
    
    ' 创建Outlook邮件
    Set olApp = CreateObject("Outlook.Application")
    Set olMail = olApp.CreateItem(0)
    With olMail
        .To = "收件人邮箱@你的域名.com"
        .Subject = "筛选后数据"
        .Body = "请查收附件。"
        .Attachments.Add ActiveWorkbook.FullName
        .Display
    End With
    
    ' 等待3分钟（可根据实际调整，单位时:分:秒）
    Application.Wait Now() + TimeValue("00:03:00")
    
    ' 清除筛选
    ActiveSheet.AutoFilterMode = False
End Sub

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