修改Outlook自带回复/全部回复功能，添加原邮件附件

你遇到的异常是因为：Outlook自带的「回复/全部回复」按钮触发默认事件时，会自动生成一封无附件的回复邮件；而你的代码中又调用了myItem.Reply/myItem.ReplyAll方法，导致同时生成两封邮件；若未阻止默认行为，Outlook只会显示它自动生成的无附件邮件，最终出现「无附件」或「两封邮件」的问题。

核心思路是取消Outlook默认回复行为，然后在事件中手动创建带附件的回复邮件，具体实现步骤如下：

1. 创建类模块处理邮件事件 #

打开Outlook VBA编辑器（按Alt+F11），右键点击项目 → 插入 → 类模块，命名为MailItemEvents，粘贴以下代码：

Option Explicit
Option Compare Text
Public WithEvents oMail As Outlook.MailItem

Private Sub oMail_Reply(ByVal Response As Object, Cancel As Boolean)
    ' 取消Outlook默认回复行为
    Cancel = True
    ' 自定义带附件的回复逻辑
    Dim oReply As Outlook.MailItem
    Set oReply = oMail.Reply
    AddOriginalAttachments oMail, oReply
    oReply.Display
    oMail.UnRead = False
    Set oReply = Nothing
End Sub

Private Sub oMail_ReplyAll(ByVal Response As Object, Cancel As Boolean)
    ' 取消Outlook默认全部回复行为
    Cancel = True
    ' 自定义带附件的全部回复逻辑
    Dim oReplyAll As Outlook.MailItem
    Set oReplyAll = oMail.ReplyAll
    AddOriginalAttachments oMail, oReplyAll
    oReplyAll.Display
    oMail.UnRead = False
    Set oReplyAll = Nothing
End Sub

2. 创建类模块处理浏览器选中事件 #

再插入一个类模块，命名为ExplorerEvents，粘贴以下代码：

Option Explicit
Public WithEvents oExplorer As Outlook.Explorer

Private Sub oExplorer_SelectionChange()
    ' 选中邮件变化时，重新绑定邮件事件
    InitializeMailItemEvents
End Sub

3. 创建标准模块整合逻辑 #

插入一个标准模块，命名为MainModule，粘贴以下代码：

Option Explicit
Option Compare Text
Dim colMailEvents As New Collection
Dim oExplorerEvent As ExplorerEvents

Sub Application_Startup()
    ' Outlook启动时绑定浏览器选中事件
    Set oExplorerEvent = New ExplorerEvents
    Set oExplorerEvent.oExplorer = Application.ActiveExplorer
End Sub

Sub InitializeMailItemEvents()
    Dim objApp As Outlook.Application
    Dim objSelection As Outlook.Selection
    Dim objItem As Object
    Dim oMailEvent As MailItemEvents
    
    Set objApp = Application
    Set objSelection = objApp.ActiveExplorer.Selection
    
    ' 清空旧的事件监听
    Set colMailEvents = New Collection
    
    ' 为选中的每封邮件绑定事件
    For Each objItem In objSelection
        If TypeName(objItem) = "MailItem" Then
            Set oMailEvent = New MailItemEvents
            Set oMailEvent.oMail = objItem
            colMailEvents.Add oMailEvent
        End If
    Next
    
    Set objItem = Nothing
    Set objSelection = Nothing
    Set objApp = Nothing
End Sub

' 保留你原有的工具函数和自定义按钮逻辑
Function GetCurrentItem() As Object
    Dim objApp As Outlook.Application
    Set objApp = Application
    Select Case TypeName(objApp.ActiveWindow)
        Case "Explorer"
            Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1)
        Case "Inspector"
            Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
    End Select
    Set objApp = Nothing
End Function

Sub AddOriginalAttachments(ByVal myItem As Object, ByVal myResponse As Object)
    Dim fldTemp As Object, strPath As String, strFile As String
    Dim myAttachments As Variant, attach As Attachment
    Dim fso As New FileSystemObject
    
    Set myAttachments = myResponse.Attachments
    Set fldTemp = fso.GetSpecialFolder(2)    ' 用户临时文件夹
    strPath = fldTemp.Path & "\\"
    
    For Each attach In myItem.Attachments
      If Not attach.FileName Like "*image###.png" And _
         Not attach.FileName Like "*image###.jpg" And _
         Not attach.FileName Like "*image###.gif" Then
        strFile = strPath & attach.FileName
         attach.SaveAsFile strFile
          myAttachments.Add strFile, , , attach.DisplayName
           fso.DeleteFile strFile
      End If
    Next
    
    Set fldTemp = Nothing
    Set fso = Nothing
    Set myAttachments = Nothing
End Sub

Sub ReplyWithAttachments()
    ReplyAndAttach (False)
End Sub

Sub ReplyAllWithAttachments()
    ReplyAndAttach (True)
End Sub

Sub ReplyAndAttach(ByVal ReplyAll As Boolean)
    Dim myItem As Outlook.MailItem
    Dim oReply As Outlook.MailItem
    
    Set myItem = GetCurrentItem()
    
    If Not myItem Is Nothing Then
        If ReplyAll = False Then
            Set oReply = myItem.Reply
        Else
            Set oReply = myItem.ReplyAll
        End If
        
        AddOriginalAttachments myItem, oReply
        oReply.Display
        myItem.UnRead = False
    End If
    
    Set oReply = Nothing
    Set myItem = Nothing
End Sub

4. 引用必要组件 #

在VBA编辑器中，点击「工具」→「引用」，勾选Microsoft Scripting Runtime，否则FileSystemObject会报错。

5. 生效设置 #

保存所有代码，重启Outlook。之后选中邮件点击自带的「回复/全部回复」按钮，只会生成一封带附件的回复邮件，自定义按钮的功能也会保留正常使用。

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