List attachments in Outlook email under signature - vba

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

You will probably need to make some adjustments, but you can use some of the existing code and just put it in the ItemSend event procedure:
This will automatically list the attachments whenever you send an email.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim oAtt As Attachment
Dim strAtt As String
Dim olInspector As Inspector
Dim olDocument As Object
Dim olSelection As Object
For Each oAtt In Item.Attachments
strAtt = strAtt & "<<" & oAtt.filename & ">> "
Next
Set olInspector = Application.ActiveInspector()
Set olDocument = olInspector.WordEditor
Set olSelection = olDocument.Application.Selection
olSelection.InsertBefore strAtt
End Sub
It's certainly possible to do this using Ribbon customization, i.e., to hijack an existing context-menu so you would have an option to right-click & display attachment names, but frankly Ribbon UI development is fairly advanced technique and probably overkill for this specific need.

Answer 2

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