取消电子邮件草稿后，Outlook VBA oItem_ReplyAll将停止触发_Vba_Email_Outlook

取消电子邮件草稿后，Outlook VBA oItem_ReplyAll将停止触发

vba email outlook

取消电子邮件草稿后，Outlook VBA oItem_ReplyAll将停止触发,vba,email,outlook,Vba,Email,Outlook,我正在使用以下代码在我回复的电子邮件文本中输入附件的名称我使用两个几乎相同的脚本来处理Reply和Reply all。当我启动outlook时，它们工作正常，但过一段时间就会失败。我可以通过回复电子邮件然后取消发送来重现失败如果我发送电子邮件，那么脚本将无限期地工作，直到我退出电子邮件窗口而不是按send 取消导致脚本停止调用的发送是什么原因 Option Explicit Private WithEvents oExpl As Explorer Private WithEvents oIt

我正在使用以下代码在我回复的电子邮件文本中输入附件的名称

我使用两个几乎相同的脚本来处理Reply和Reply all。当我启动outlook时，它们工作正常，但过一段时间就会失败。我可以通过回复电子邮件然后取消发送来重现失败

如果我发送电子邮件，那么脚本将无限期地工作，直到我退出电子邮件窗口而不是按send

取消导致脚本停止调用的发送是什么原因

Option Explicit
Private WithEvents oExpl As Explorer
Private WithEvents oItem As MailItem
Private bDiscardEvents, Cancel As Boolean
Private strAtt, FinalMsg As String
Private oAtt As Attachment
Private oResponse As MailItem

' Reply All
Private Sub oItem_ReplyAll(ByVal Response As Object, Cancel As Boolean)


Dim FinalMsg As String
Dim olInspector As Outlook.Inspector
Dim olDocument As Word.Document
Dim olSelection As Word.Selection

If bDiscardEvents = True Or oItem.Attachments.Count = 0 Then
       Exit Sub
End If

Cancel = True
bDiscardEvents = True
strAtt = ""

Call GoodExtensions 'Detect extensions to be included and put them into strAtt

If strAtt = "" Then Exit Sub 'quit if there are no attachments
FinalMsg = "Attached" & ": " & strAtt

    Set oResponse = oItem.ReplyAll
    oResponse.Display
    If oResponse.BodyFormat = olFormatPlain Then oResponse.BodyFormat = olFormatHTML 'prevent plaintext emails causing problems

    Set olInspector = Application.ActiveInspector()
    Set olDocument = olInspector.WordEditor
    Set olSelection = olDocument.Application.Selection


 'Find the beginning of the email being replied to
With ActiveInspector.WordEditor.Application
    .Selection.WholeStory
    .Selection.Find.ClearFormatting
    With .Selection.Find
        .Text = "Subject:"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindAsk
        .Format = False
        .Execute
    End With

    Dim SubjectFont As String 'capture formatting details from the "From:" text to allow blending
    Dim SubjectSize As Integer
    SubjectFont = .Selection.Font.Name
    SubjectSize = .Selection.Font.Size

    .Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdMove
    .Selection.HomeKey Unit:=wdLine
    .Selection.EndKey Unit:=wdLine, Extend:=wdExtend
    If InStr(.Selection.Text, "mportance") <> 0 Then
    .Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdMove
    End If

End With

'Insert the message and format it to blend in
olSelection.InsertBefore FinalMsg
olSelection.Font.Name = SubjectFont
olSelection.Font.Size = SubjectSize
olSelection.Font.Color = wdColorBlack
olSelection.EndKey Unit:=wdLine
olSelection.TypeParagraph

'Embolden the word "Attached:" to ensure formatting compatibilty
With ActiveInspector.WordEditor.Application
    .Selection.WholeStory
    .Selection.Find.ClearFormatting
    With .Selection.Find
        .Text = "Attached:"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindAsk
        .Format = False
        .MatchCase = True
        .Execute
    End With

.Selection.Font.Bold = True
End With

bDiscardEvents = False
Set oItem = Nothing


End Sub

选项显式
私有WithEvents oExpl作为资源管理器
Private WithEvents oItem作为邮件项
私有bDiscardEvents，取消为布尔值
二等兵斯特拉特，最后一队
私人oAtt作为附件
私人或作为邮件项目响应
“全部答复
私有子oItem_ReplyAll（ByVal响应作为对象，Cancel作为布尔值）
作为字符串的Dim FinalMsg
作为Outlook.Inspector的检查程序
Dim OldDocument作为Word.Document
选择作为单词。选择
如果bDiscardEvents=True或oItem.Attachments.Count=0，则
出口接头
如果结束
取消=真
bDiscardEvents=True
strAtt=“”
调用GoodExtensions检测要包含的扩展，并将它们放入strAtt
如果strAtt=“”，则退出Sub“如果没有附件，则退出”
FinalMsg=“附加”&“&strAtt”
设置或响应=oItem.replyll
响应，显示
如果oResponse.BodyFormat=olFormatPlain，则oResponse.BodyFormat=olFormatHTML'防止明文电子邮件引起问题
设置olInspector=Application.ActiveInspector（）
Set olDocument=olInspector.WordEditor
设置olSelection=olDocument.Application.Selection
'查找要回复的电子邮件的开头
使用ActiveInspector.WordEditor.Application
.选择
.Selection.Find.ClearFormatting
With.Selection.Find
.Text=“主题：”
.Replacement.Text=“”
.Forward=True
.Wrap=wdFindAsk
.Format=False
.执行
以
Dim SubjectFont As String'从“from:”文本中捕获格式细节以允许混合
将SubjectSize设置为整数
SubjectFont=.Selection.Font.Name
SubjectSize=.Selection.Font.Size
.Selection.MoveDown单位：=wdLine，计数：=1，扩展：=wdMove
.Selection.HOME键单位：=wdLine
.Selection.EndKey单位：=wdLine，扩展：=wdExtend
如果InStr（.Selection.Text，“importance”）为0，则
.Selection.MoveDown单位：=wdLine，计数：=1，扩展：=wdMove
如果结束
以
'插入消息并格式化以融入其中
olSelection.InsertBefore FinalMsg
olSelection.Font.Name=主题字体
olSelection.Font.Size=主题大小
olSelection.Font.Color=wdColorBlack
olSelection.EndKey单位：=wdLine
olSelection.typeparation
“添加”一词以确保格式兼容性
使用ActiveInspector.WordEditor.Application
.选择
.Selection.Find.ClearFormatting
With.Selection.Find
.Text=“附件：”
.Replacement.Text=“”
.Forward=True
.Wrap=wdFindAsk
.Format=False
.MatchCase=True
.执行
以
.Selection.Font.Bold=True
以
bDiscardEvents=False
设置oItem=无
端接头

看起来，最终将oItem设置为“无”是导致问题的原因。删除这一行后，我无法再复制问题。我的代码如下

' Reply All
Private Sub oItem_ReplyAll(ByVal Response As Object, Cancel As Boolean)


Dim FinalMsg As String
Dim olInspector As Outlook.Inspector
Dim olDocument As Word.Document
Dim olSelection As Word.Selection

If bDiscardEvents Or oItem.Attachments.Count = 0 Then
       Exit Sub
End If

Cancel = True
bDiscardEvents = True
strAtt = ""

Call GoodExtensions 'Detect extensions to be included and put them into strAtt

If strAtt = "" Then Exit Sub 'quit if there are no attachments
FinalMsg = "Attached" & ": " & strAtt

    Set oResponse = oItem.ReplyAll
    oResponse.Display
    If oResponse.BodyFormat = olFormatPlain Then oResponse.BodyFormat = olFormatHTML 'prevent plaintext emails causing problems

    Set olInspector = Application.ActiveInspector()
    Set olDocument = olInspector.WordEditor
    Set olSelection = olDocument.Application.Selection


 'Find the beginning of the email being replied to
With ActiveInspector.WordEditor.Application
    .Selection.WholeStory
    .Selection.Find.ClearFormatting
    With .Selection.Find
        .Text = "Subject:"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindAsk
        .Format = False
        .Execute
    End With
    'capture formatting details from the "From:" text to allow blending
    Dim SubjectFont As String
    Dim SubjectSize As Integer
    Dim SubjectBold As Boolean
    SubjectFont = .Selection.Font.Name
    SubjectSize = .Selection.Font.Size
    SubjectBold = .Selection.Font.Bold

    .Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdMove
    .Selection.HomeKey Unit:=wdLine
    .Selection.EndKey Unit:=wdLine, Extend:=wdExtend
    If InStr(.Selection.Text, "mportance") <> 0 Then
    .Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdMove
    End If

End With

'Insert the message and format it to blend in
olSelection.InsertBefore FinalMsg
olSelection.Font.Name = SubjectFont
olSelection.Font.Size = SubjectSize
olSelection.Font.Color = wdColorBlack
olSelection.EndKey Unit:=wdLine
olSelection.TypeParagraph

'Embolden the word "Attached:" if necessary to ensure formatting compatibility
With ActiveInspector.WordEditor.Application
    .Selection.WholeStory
    .Selection.Find.ClearFormatting
    With .Selection.Find
        .Text = "Attached:"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindAsk
        .Format = False
        .MatchCase = True
        .Execute
    End With

.Selection.Font.Bold = SubjectBold
End With

bDiscardEvents = False
'Set oItem = Nothing
Exit Sub

End Sub

“全部回复”
私有子oItem_ReplyAll（ByVal响应作为对象，Cancel作为布尔值）
作为字符串的Dim FinalMsg
作为Outlook.Inspector的检查程序
Dim OldDocument作为Word.Document
选择作为单词。选择
如果bDiscardEvents或oItem.Attachments.Count=0，则
出口接头
如果结束
取消=真
bDiscardEvents=True
strAtt=“”
调用GoodExtensions检测要包含的扩展，并将它们放入strAtt
如果strAtt=“”，则退出Sub“如果没有附件，则退出”
FinalMsg=“附加”&“&strAtt”
设置或响应=oItem.replyll
响应，显示
如果oResponse.BodyFormat=olFormatPlain，则oResponse.BodyFormat=olFormatHTML'防止明文电子邮件引起问题
设置olInspector=Application.ActiveInspector（）
Set olDocument=olInspector.WordEditor
设置olSelection=olDocument.Application.Selection
'查找要回复的电子邮件的开头
使用ActiveInspector.WordEditor.Application
.选择
.Selection.Find.ClearFormatting
With.Selection.Find
.Text=“主题：”
.Replacement.Text=“”
.Forward=True
.Wrap=wdFindAsk
.Format=False
.执行
以
'从“发件人：”文本中捕获格式详细信息以允许混合
将主题字体设置为字符串
将SubjectSize设置为整数
Dim SubjectBold为布尔值
SubjectFont=.Selection.Font.Name
SubjectSize=.Selection.Font.Size
SubjectBold=.Selection.Font.Bold
.Selection.MoveDown单位：=wdLine，计数：=1，扩展：=wdMove
.Selection.HOME键单位：=wdLine
.Selection.EndKey单位：=wdLine，扩展：=wdExtend
如果InStr（.Selection.Text，“importance”）为0，则
.Selection.MoveDown单位：=wdLine，计数：=1，扩展：=wdMove
如果结束
以
'插入消息并格式化以融入其中
olSelection.InsertBefore FinalMsg
olSelection.Font.Name=主题字体
olSelection.Font.Size=主题大小
olSelection.Font.Color=wdColorBlack
olSelection.EndKey单位：=wdLine
olSelection.typeparation
如果需要确保格式兼容性，请使用“附加”一词
使用ActiveInspector.WordEditor.Application
.选择
.Selection.Find.ClearFormatting
With.Selection.Find
.Text=“附件：”
.Replacement.Text=“”
.Forward=True
.Wrap=wdFindAsk
.Format=False
.MatchCase=True
.执行
以
.Selection.Font.Bold=主题粗体
以
bDiscardEvents=False
'Set oItem=无
出口接头
端接头

结果是我

Option Explicit
Private WithEvents oExpl As Explorer
Private WithEvents oItem As MailItem
Private bDiscardEvents, Cancel As Boolean
Private strAtt, FinalMsg As String
Private oAtt As Attachment
Private oResponse As MailItem

 Private Sub Application_Startup()
   Set oExpl = Application.ActiveExplorer
   bDiscardEvents = False
End Sub

Private Sub oExpl_SelectionChange()
   On Error Resume Next
   Set oItem = oExpl.Selection.item(1)
End Sub

' Reply
Private Sub oItem_Reply(ByVal Response As Object, Cancel As Boolean)
'''''''''''''''''''''''''''''''''''''''''''
' This adds the name of any attachments   '
' in an email to the reply of said email. '
'''''''''''''''''''''''''''''''''''''''''''

'Dim finalmsg As String
Dim olInspector As Outlook.Inspector
Dim olDocument As Word.Document
Dim olSelection As Word.Selection

If oItem.Attachments.Count = 0 Then 
       Exit Sub
End If

Cancel = True
bDiscardEvents = True

Call GoodExtensions

If strAtt = "" Then Exit Sub
FinalMsg = "Attached" & ": " & strAtt


Set oResponse = oItem.Reply
oResponse.Display
If oResponse.BodyFormat = olFormatPlain Then oResponse.BodyFormat = olFormatHTML 'prevent plaintext emails causing problems


Call insertAttachmentList

bDiscardEvents = False
'Set oItem = Nothing

End Sub
' Reply All
Private Sub oItem_ReplyAll(ByVal Response As Object, Cancel As Boolean)
'''''''''''''''''''''''''''''''''''''''''''
' This adds the name of any attachments   '
' in an email to the reply of said email. '
'''''''''''''''''''''''''''''''''''''''''''

Dim olInspector As Outlook.Inspector
Dim olDocument As Word.Document
Dim olSelection As Word.Selection

If oItem.Attachments.Count = 0 then Exit Sub

Cancel = True
bDiscardEvents = True

Call GoodExtensions 'Detect extensions to be included and put them into strAtt

If strAtt = "" Then Exit Sub 'quit if there are no attachments
FinalMsg = "Attached" & ": " & strAtt

    Set oResponse = oItem.ReplyAll
    oResponse.Display
    If oResponse.BodyFormat = olFormatPlain Then oResponse.BodyFormat = olFormatHTML 'prevent plaintext emails causing problems


Call insertAttachmentList

bDiscardEvents = False
'Set oItem = Nothing
Exit Sub

End Sub
Sub insertAttachmentList()

 'Find the beginning of the email being replied to
With ActiveInspector.WordEditor.Application
    .Selection.WholeStory
    .Selection.Find.ClearFormatting
    With .Selection.Find
        .Text = "Subject:"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindAsk
        .Format = False
        .Execute
    End With
    If Not InStr(.Selection.Text, "ubject") <> 0 Then
        msg = MsgBox("Subject line not found. Abort", vbCritical)
        Exit Sub
    End If
    'capture formatting details from the "From:" text to allow blending
    Dim SubjectFont As String
    Dim SubjectSize As Integer
    Dim SubjectBold As Boolean
    SubjectFont = .Selection.Font.Name
    SubjectSize = .Selection.Font.Size
    SubjectBold = .Selection.Font.Bold

    .Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdMove
    .Selection.HomeKey Unit:=wdLine
    .Selection.EndKey Unit:=wdLine, Extend:=wdExtend
    If InStr(.Selection.Text, "mportance") <> 0 Then
    .Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdMove
    End If

End With

'Insert the message and format it to blend in
With Application.ActiveInspector.WordEditor.Application.Selection
    .InsertBefore FinalMsg
    .Font.Name = SubjectFont
    .Font.Size = SubjectSize
    .Font.Color = wdColorBlack
    .EndKey Unit:=wdLine
    .TypeParagraph
End With

'Embolden the word "Attached:" if necessary to ensure formatting compatibility
With ActiveInspector.WordEditor.Application
    .Selection.WholeStory
    .Selection.Find.ClearFormatting
    With .Selection.Find
        .Text = "Attached:"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindAsk
        .Format = False
        .MatchCase = True
        .Execute
    End With

.Selection.Font.Bold = SubjectBold
End With
MsgBox "Attachment text added"
End Sub


Sub GoodExtensions()
Dim AttachName As String
FinalMsg = ""
strAtt = ""
For Each oAtt In oItem.Attachments
AttachName = LCase(oAtt.FileName)
    If InStr(LCase(AttachName), "pdf") <> 0 Or InStr(LCase(AttachName), "xls") <> 0 Or InStr(LCase(AttachName), "doc") <> 0 _
            Or InStr(LCase(AttachName), "ppt") <> 0 Or InStr(LCase(AttachName), "msg") <> 0 Or InStr(LCase(AttachName), "mac") <> 0 _
            Or InStr(LCase(AttachName), "arc") <> 0 Or InStr(LCase(AttachName), "prj") <> 0 Or InStr(LCase(AttachName), "rsl") <> 0 _
            Or InStr(LCase(AttachName), "results") <> 0 Or InStr(LCase(AttachName), "screenshot") <> 0 Or InStr(LCase(AttachName), "vtc") <> 0 _
            Or InStr(LCase(AttachName), "BLANK_PARAMETER") <> 0 Or InStr(LCase(AttachName), "BLANK_PARAMETER") <> 0 Or InStr(LCase(AttachName), "BLANK_PARAMETER") <> 0 _
            Or oAtt.Size > 95200 Then
            strAtt = strAtt & "<" & oAtt.FileName & ">, "
    End If
Next oAtt

End Sub
'This sub inserts the name of any meaningful attachments just after the signature
Private Sub Application_ItemSend(ByVal item As Object, Cancel As Boolean)
Dim oAtt As Attachment
Dim strAtt, DateMark, ShortTime, FinalMsg, AttachName, TriggerText  As String
Dim olInspector, oInspector As Inspector
Dim olDocument, olSelection As Object
Dim NewMail As MailItem
Dim AttchCount, i As Integer
strAtt = ""
FinalMsg = ""
'Stop
TriggerText = "Company Registration 1702660" 'This must be the last line of your signature or other place you want to insert the attachment text. It needs to be present in every email.

If TypeOf item Is MailItem Then Set NewMail = item
If item.Class = olMeetingRequest Then Exit Sub

With NewMail
    AttchCount = .Attachments.Count

    If AttchCount > 0 Then
        For i = 1 To AttchCount
        AttachName = .Attachments.item(i).DisplayName
            If InStr(LCase(AttachName), "pdf") <> 0 Or InStr(LCase(AttachName), "xls") <> 0 Or InStr(LCase(AttachName), "doc") <> 0 _
            Or InStr(LCase(AttachName), "ppt") <> 0 Or InStr(LCase(AttachName), "msg") <> 0 Or InStr(LCase(AttachName), "mac") <> 0 _
            Or InStr(LCase(AttachName), "arc") <> 0 Or InStr(LCase(AttachName), "prj") <> 0 Or InStr(LCase(AttachName), "rsl") <> 0 _
            Or InStr(LCase(AttachName), "results") <> 0 Or InStr(LCase(AttachName), "screenshot") <> 0 Or InStr(LCase(AttachName), "BLANK_PARAMETER") <> 0 _
            Or .Attachments.item(i).Size > 95200 Then
                strAtt = strAtt & "[" & AttachName & "] " & "<br/>"
            End If
        Next i
    End If
End With

' this section is an alternative method of getting attachment names
'For Each oAtt In Item.Attachments
'    If InStr(oAtt.FileName, "xls") <> 0 Or InStr(oAtt.FileName, "doc") <> 0 Or InStr(oAtt.FileName, "pdf") <> 0 Or InStr(oAtt.FileName, "ppt") <> 0 Or InStr(oAtt.FileName, "msg") <> 0 Or oAtt.Size > 95200 Then
'    strAtt = strAtt & "<<" & oAtt.FileName & ">> " & vbNewLine
'End If
'Next
'Set olInspector = Application.ActiveInspector()
'Set olDocument = olInspector.WordEditor
'Set olSelection = olDocument.Application.Selection

DateMark = "" '" (dated " & Date & ")" 'Not necessary when sub works well
If strAtt = "" Then 'Reduce risk of erroneous entries.
    FinalMsg = ""
    'Exit Sub
Else
    FinalMsg = "<br/><br/>" & "Files attached to this email" & DateMark & ":<br/>" & vbNewLine & strAtt
End If

Dim inputArea, SearchTerm As String
Dim SignatureLine, FromLine, EndOfEmail As Integer

If Not item.BodyFormat = 2 Then item.BodyFormat = 2 'force use of html
item.HTMLBody = Replace(item.HTMLBody, TriggerText & ".", TriggerText & FinalMsg)
If Not FinalMsg = "" Then MsgBox Replace(FinalMsg, "<br/>", vbNewLine)
'Stop
Exit Sub

If bDiscardEvents = True Or oItem.Attachments.Count = 0 Then
       Exit Sub
End If