List attachments in Outlook email under signature

Question

I am experienced with VBA in Excel but very new to it in Outlook. Does anyone know of a script to list the attachments in an outgoing email, under the signature? To be triggered by a ribbon item or keyboard shortcut?

I often send emails with attachments and would like to know what I sent by looking at any email in the conversation rather than having to find the email with the attached items.

Hopefully this image will clarify:

I would like to generate the last line of that email. I have a script to extract this info when replying to emails* but I don't know how to get attachment info out of an email I am about to send.

* Available here: http://www.slipstick.com/developer/code-samples/insert-attachment-names-replying/

Answer 1

This is my solution. On "send" it detects desired attachment names and then appends them just after the signature. If there is an existing list of attachments then it overwrites it.

I have used the with function to encapsulate separate sections - the "'check to see if attachment info has already been added" section is optional. To use this in a standard module just replace the second line with sub() AttachmentLister

'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 As String
Dim olInspector, oInspector As Inspector
Dim olDocument As Object
Dim olSelection As Object
Dim NewMail As MailItem
Dim AttchCount, i As Integer

Set oInspector = Application.ActiveInspector
Set NewMail = oInspector.CurrentItem

With NewMail
    AttchCount = .Attachments.Count

    If AttchCount > 0 Then
        For i = 1 To AttchCount
        AttachName = .Attachments.Item(i).DisplayName
            If InStr(AttachName, "pdf") <> 0 Or InStr(AttachName, "xls") <> 0 Or InStr(AttachName, "doc") <> 0 Then
                strAtt = strAtt & "<<" & AttachName & ">> " & vbNewLine
            End If
        Next i
    End If
End With

GoTo skipsect ' 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
skipsect:


'ShortTime = Format(Time, "Hh") & ":" & Format(Time, "Nn") & " "
DateMark = " (dated " & Date & ShortTime & ")"
If strAtt = "" Then
FinalMsg = ""
Else
FinalMsg = "Documents attached to this email" & DateMark & ": " & vbNewLine & strAtt
End If

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

'Find the end of the signature
With ActiveInspector.WordEditor.Application
    .Selection.WholeStory
    .Selection.Find.ClearFormatting
    With .Selection.Find
        .Text = "Sales Co-ordinator"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindAsk
        .Format = False
        .MatchCase = False
    End With
    .Selection.Find.Execute
    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:=4, Extend:=wdExtend
    inputArea = .Selection
    .Selection.MoveUp Unit:=wdLine, Count:=4, Extend:=wdExtend

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


    '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 = "mailto"
                .Replacement.Text = ""
                .Forward = True
                .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:=wdMove
        .Selection.MoveUp Unit:=wdLine, Count:=EndOfEmail - SignatureLine, Extend:=wdExtend
        .Selection.Expand wdLine
        .Selection.Delete
    End If
End With

'Insert the text and format it.
With ActiveInspector.WordEditor.Application
    .Selection.TypeParagraph
    .Selection.InsertAfter FinalMsg 'insert the message at the cursor.
    .Selection.Font.Name = "Calibri"
    .Selection.Font.Size = 9
    .Selection.Font.Color = wdColorBlack
End With
lastline:
End Sub