Question

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

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

如果我发送电子邮件，则脚本无限制地无限制地工作，直到我退出电子邮件窗口而不是按发送。

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

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

Answer 1

问题是布尔值bDiscardEvents的使用-特别是在测试中的使用

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

在这里使用它会导致子例程始终退出，如果子例程在退出例程之前在设置false之前被调用，例如在If strAtt = "" Then Exit Sub触发之后。布尔值不是必需的，可以将其删除。

诊断是此布尔值已在Diane Poremsky的某些宏（www.slipstick.com /）中使用，我确定您的代码是从那里继承的。但是，这里不是必需的。她本人曾被询问是否使用过与您说的功能类似的产品

“在此版本的宏中，它似乎没有执行任何操作... 在原始宏中，它的使用方式与取消很相似。当宏已针对此示例进行了编辑，但并未删除。 :(“

Answer 2

看起来好像将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

Answer 3

事实证明我仍然遇到了问题，但现在看来代码完全正常，因为删除了bdiscardevents标准 - 我从未诊断出这甚至应该做什么。

我已经粘贴了我的整个ThisOutlookSession，因为它仅用于附件检测，并且以我无法解开的方式交织在一起。我欢迎任何反馈。

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

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

3 个答案: