Add the names of attachments to the body of an outgoing email

Question

I had a script which did this well in outlook 2010 but since upgrading to outlook 2013 it crashes at a number of different points. I wonder if anyone else has a way to do it or can see if it can be repaired?

It seems to crash at a number of the olDocument, oInspector, ActiveInspector.WordEditor.Application steps, depending on how the wind is blowing.

Thanks for any help

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
'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 As Object
Dim olSelection As Object
Dim NewMail As MailItem
Dim AttchCount, i As Integer
Exit Sub

TriggerText = "Joe Bloggs"

If oInspector Is Nothing Then
     'Set NewMail = Application.ActiveExplorer.Selection.Item(1)
     Set NewMail = oExpl.ActiveInlineResponse
     If NewMail Is Nothing Then
        'MsgBox "No active inspector or inline response"
        Exit Sub
     End If
Else
    Set NewMail = oInspector.CurrentItem
End If 'oInspector is Nothing

Set oInspector = Application.ActiveInspector
If oInspector.CurrentItem.Class = olAppointment Then End



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 .Attachments.item(i).Size > 95200 Then
                strAtt = strAtt & "<<" & AttachName & ">> " & vbNewLine
            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 & ")" 'Date not necessary now this is working well
If strAtt = "" Then
FinalMsg = ""
Exit Sub
Else
FinalMsg = "Documents attached to this email" & DateMark & ": " & vbNewLine & strAtt
End If

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



'Find the end of the signature
With ActiveInspector.WordEditor.Application 'Might be able to use: Application.ActiveWindow.CurrentItem

    .Selection.WholeStory
    .Selection.Find.ClearFormatting
    With .Selection.Find
        .Text = TriggerText
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindAsk
        .Format = False
        .MatchCase = False
        .Execute
    End With
    SignatureLine = .Selection.Range.Information(wdFirstCharacterLineNumber) + 1
    .Selection.EndKey Unit:=wdLine
End With

'check to see if attachment info has already been added
With ActiveInspector.WordEditor.Application
    .Selection.MoveDown Unit:=wdLine, Count:=3, Extend:=wdExtend
    inputArea = .Selection
    .Selection.HomeKey Unit:=wdLine
    .Selection.EndKey Unit:=wdLine
    'SelectedLine = .Selection.Range.Information(wdFirstCharacterLineNumber) + 1


    'detect existing attachment lists
    If Not InStr(inputArea, "Documents attached to this email") <> 0 Then
        .Selection.EndKey Unit:=wdLine
        .Selection.TypeParagraph
    Else
        With .Selection.Find
            .Text = "From:"
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindAsk
            .Format = False
            .MatchCase = True
            .Execute
        End With
    FromLine = .Selection.Range.Information(wdFirstCharacterLineNumber) + 1

    'In case the email being replied to is not in english,
    'try to detect the first line of the next email by looking for mailto
        If .Selection.Find.Found = False Then
            With .Selection.Find
                .Text = ">>"
                .Replacement.Text = ""
                .Forward = False
                .Wrap = wdFindAsk
                .Format = False
                .Execute
            End With
        End If


        'designate the last line of the email and delete anything between this and the signature
        EndOfEmail = .Selection.Range.Information(wdFirstCharacterLineNumber) - 1
        .Selection.MoveUp Unit:=wdLine, Count:=1, Extend:=wdExtend
        .Selection.EndKey Unit:=wdLine
        .Selection.MoveUp Unit:=wdLine, Count:=EndOfEmail - SignatureLine, Extend:=wdExtend
        .Selection.Expand wdLine
        .Selection.Delete
    End If
End With

'Insert the text and format it.
If Not NewMail.BodyFormat = olFormatPlain Then
    With ActiveInspector.WordEditor.Application
        .Selection.TypeParagraph
        .Selection.InsertAfter FinalMsg 'insert the message at the cursor.
        .Selection.Font.Name = "Calibri"
        .Selection.Font.Size = 8
        .Selection.Font.Color = wdColorBlack
        .Selection.EndKey Unit:=wdLine
        'If FromLine - EndOfEmail < 2 Then .Selection.TypeParagraph
        '.Selection.Delete
    End With
End If
lastline:
End Sub

Answer 1

You pass "item As Object" so you do not have to find it again.

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 As Object
    Dim olSelection As Object
    Dim NewMail As MailItem
    Dim AttchCount, i As Integer

    TriggerText = "Joe Bloggs"

    'If oInspector Is Nothing Then
    '    'Set NewMail = Application.ActiveExplorer.Selection.Item(1)
    '   Set NewMail = oExpl.ActiveInlineResponse
    '  If NewMail Is Nothing Then
    '       'MsgBox "No active inspector or inline response"
    '       Exit Sub
    '    End If
    'Else
    '    Set NewMail = oInspector.currentItem
    'End If 'oInspector is Nothing

    'Set oInspector = Application.ActiveInspector
    'If oInspector.currentItem.Class = olAppointment Then End

    If TypeOf item Is MailItem Then

        Set NewMail = item

        With NewMail ' In future coding you need not bother to set NewMail just use item

Answer 2

You need to use the Body or HTMLBody properties for customizing the message body in the ItemSend event handler. The Word editor may not be available at this stage, i.e. it can be too late. Also changes made using the WordEditor property in the Send or ItemSend event are not saved. Take a look at the described similar issue for more information.