更改 Outlook（回复和全部回复）本身的行为，将原始电子邮件中的附件添加到回复的邮件中

Question

如您所知，当您使用 Outlook 并使用（回复/全部回复）电子邮件时，原始附件不包含在回复的邮件中。
因此，我使用了以下代码并分配给 Outlook 功能区上的自定义按钮，并且它可以正常工作。
我需要将我的代码直接分配给 Outlook 内置函数本身（回复和回复全部），而不是单击我的自定义按钮。
我发现 Outlook 提供了两个事件

oMailItem Object

oMailItem_Reply 和 oMailItem_ReplyAll。
我是这样用的：

Private Sub oMailItem_Reply(ByVal Response As Object, Cancel As Boolean)
    Call ReplyWithAttachments
End Sub
 
Private Sub oMailItem_ReplyAll(ByVal Response As Object, Cancel As Boolean)
   Call ReplyAllWithAttachments
End Sub

但是，当我单击 Outlook（回复和回复全部）本身时，会发生以下行为之一：
1- 创建了一封新的回复电子邮件，根本没有任何附件，
2- 或者新回复的电子邮件创建两次，一封包含附件，另一封不包含任何附件。
这是将原始电子邮件中的附件添加到回复电子邮件的完整工作代码：

Option Explicit
Option Compare Text
Sub ReplyWithAttachments()
    ReplyAndAttach (False)
End Sub
Sub ReplyAllWithAttachments()
    ReplyAndAttach (True)
End Sub
 
Function GetCurrentItem() As Object
 
    Dim objApp As Outlook.Application
 
    Set objApp = Application
'  On Error Resume Next
    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
 
    Set myAttachments = myResponse.Attachments
 
    Dim fso As New FileSystemObject
 
    Set fldTemp = fso.GetSpecialFolder(2)    'User Temp Folder
    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 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

Answer 1

1. 请复制

   ThisOutlookSession

   代码模块顶部（声明区域）中的以下声明：

  'new variables: _________________________________
  Private WithEvents myExplorer As Outlook.Explorer
  Private WithEvents myitemExpl As Outlook.MailItem
  '________________________________________________

  Private WithEvents MyItem As Outlook.MailItem
  Private WithEvents m_Inspectors As Outlook.Inspectors
  Private WithEvents m_Inspector As Outlook.Inspector

  Private Const boolNoAttach As Boolean = True 'make it true when need to add original attachments

2. 复制下一个代码事件（和两个

   Sub

   ），或者如果相应事件已存在，则添加下一个代码行：

 Private Sub Application_Startup() 'it may exist, I suggested it in another answer for you
     Initialize_Handler 
End Sub

'the next one may also exist, I think (if you did not delete it):
Private Sub m_Inspectors_NewInspector(ByVal Inspector As Outlook.Inspector)
    If TypeOf Inspector.CurrentItem Is Outlook.MailItem Then
       'Handle emails only
       Set m_Inspector = Inspector
    End If
End Sub

Private Sub m_Inspector_Activate()
  'existing declarations, if any
  '.......
 If TypeOf m_Inspector.CurrentItem Is MailItem Then
   Set MyItem = m_Inspector.CurrentItem 'it looks volatile and may be lost after using once...
   'existing code, if any...
 End if
End Sub

Private Sub myItem_PropertyChange(ByVal Name As String)
    'your existing code, if any...
    Initialize_Handler
End Sub

Sub Initialize_Handler()
 Set MyItem = Application.ActiveInspector.CurrentItem
 Set myExplorer = Application.ActiveExplorer 'new line for Explorer issues handling
End Sub

Private Sub MyItem_Reply(ByVal Response As Object, Cancel As Boolean)
  If boolNoAttach Then 'only if this constant is True
    AddOrigAttachments MyItem, Response
  End If
End Sub

Private Sub MyItem_ReplyAll(ByVal Response As Object, Cancel As Boolean)
   If boolNoAttach Then 'only if this constant is True
      AddOrigAttachments MyItem, Response
   End If
End Sub

'part dealing with Explorer issues handling:
Private Sub myExplorer_SelectionChange()
 On Error Resume Next
 Set myitemExpl = myExplorer.Selection.Item(1)
End Sub

Private Sub myitemExpl_Reply(ByVal Response As Object, Cancel As Boolean)
  If boolNoAttach Then 'only if this constant is True
    AddOrigAttachments myitemExpl, Response
  End If
End Sub
Private Sub myitemExpl_ReplyAll(ByVal Response As Object, Cancel As Boolean)
  If boolNoAttach Then 'only if this constant is True
      AddOrigAttachments myitemExpl, Response
  End If
End Sub

Sub AddOrigAttachments(ByVal MyItem As Object, ByVal myResponse As Object)
    Dim MyAttachments As Variant
    Set MyAttachments = myResponse.Attachments
    
    Dim fso As Object, fldTemp As Object, strPath As String, Attachment As Outlook.Attachment, strFile As String
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fldTemp = fso.GetSpecialFolder(2)  'User Temp Folder
    strPath = fldTemp.Path & "\"
 
    For Each Attachment In MyItem.Attachments
        strFile = strPath & Attachment.FileName
        Attachment.SaveAsFile strFile
        MyAttachments.Add strFile, , , Attachment.DisplayName
        fso.DeleteFile strFile
    Next
    
    Set fldTemp = Nothing
    Set fso = Nothing
    Set MyAttachments = Nothing
End Sub

最后一个也可能保留在标准模块中。我做了一些测试，我不记得我是否以某种方式修改了您现有的具有相似名称的

Sub

...