Save attachments and send clean emails

September 28, 2008 – 5:35 pm by JP

Do you ever need to forward attachments to someone else (maybe your boss), but don't want the ugliness of "FW: FW: re:" in the subject line? Why let others choose how your emails are going to appear -- here's an amalgam of code I've posted previously (mainly from Processing multiple emails) that does the following: You select a series of emails (or even just one email) with attachments, and the code saves all the attachments to a folder on your desktop, then re-attaches all of them to a single new email to which you can craft a new subject, and send it wherever you want.

So when 10 people in your office forward you attachments in 10 different emails, and you need to forward all of the attachments on to the same place, this code can be used to combine them all into one email.

plain text version

VBA:

Sub SaveFilesAndSendCleanEmail()
' save attachments to desktop folder (create one if necessary),
' then email them out one by one
Dim Msg As Outlook.MailItem
Dim NewMsg As Outlook.MailItem
Dim MsgColl As Object
Dim MsgAttach As Outlook.Attachments
Dim NewMsgAttach As Outlook.Attachments
Dim ThisAttach As Outlook.Attachment
Dim i As Long
Dim strMyDesktop As String
Dim strDestinationFolder As String
Dim strFileN As String
Dim fso As Object
Dim item As Object
On Error Resume Next
Set MsgColl = ActiveExplorer.Selection
On Error GoTo 0
If MsgColl Is Nothing Then
MsgBox "Nothing selected"
GoTo ExitProc
End If
' get path of user's desktop and build a string for the destination folder
strMyDesktop = MyDesktopPath & "\"
strDestinationFolder = strMyDesktop & "Saved Attachments\"
' get a FileSystemObject reference
Set fso = GetFSO
' check if the folder exists, if not then create it to store the attachments
If fso.FolderExists(strDestinationFolder) = False Then
MkDir strDestinationFolder
End If
' loop through each selected item and make sure they are all mailitems
' if so, then save each attachment from each message to the destination folder
For Each item In MsgColl
If item.Class = olMail Then ' it's an email, not a post, note, meeting request, etc
Set Msg = item
Set MsgAttach = Msg.Attachments
If MsgAttach.Count> 0 Then
For i = 1 To MsgAttach.Count
MsgAttach.item(i).SaveAsFile strDestinationFolder & MsgAttach.item(i).FileName
Next i
End If
End If
Next item
' Forward attachments to another email address
' first create the email, then loop through destination folder, adding attachments to the email and deleting them from the folder as we go
Set NewMsg = CreateItem(olMailItem)
Set NewMsgAttach = NewMsg.Attachments
strFileN = Dir(strDestinationFolder & "*.*")
Do While Len(strFileN)> 0
NewMsgAttach.Add strDestinationFolder & strFileN
Kill strDestinationFolder & strFileN
strFileN = Dir
Loop
NewMsg.Display
' clean up emails (optional)
If MsgBox("Would you like to delete the selected emails now?", vbInformation + vbYesNo) = vbYes Then
For i = 1 To MsgColl.Count
Set Msg = MsgColl.item(i)
With Msg
.UnRead = False
.Delete
End With
Next i
End If
If MsgBox("Delete destination folder that was created on your desktop?", vbInformation + vbYesNo) = vbYes Then
RmDir strDestinationFolder
End If
ExitProc:
Set Msg = Nothing
Set MsgColl = Nothing
Set MsgAttach = Nothing
Set fso = Nothing
Set NewMsg = Nothing
Set NewMsgAttach = Nothing
End Sub

The first thing you'll need to do is select the message(s) with attachments that you want to combine into one email. The code sets an object reference to the selection and saves all of the attachments from each of them.

We use an encapsulated function called MyDesktopPath, which I found in a newsgroup posting. The Windows Script Host Object Model has a SpecialFolders Method which can return the path to the end users' Desktop folder. This will let us determine the correct folder without any special or complicated programming. We'll create a temp folder called "Saved Attachments" which will store all of the attachments from all of the emails we selected.

plain text version

VBA:

Function MyDesktopPath() As String
' returns path to Desktop folder as a String
' from http://tinyurl.com/GetFolderPath
Dim WSHShell As Object
Set WSHShell = CreateObject("WScript.Shell")
MyDesktopPath = WSHShell.SpecialFolders("Desktop")
Set WSHShell = Nothing
End Function

We'll use the Scripting.FileSystemObject to check if the folder already exists. Here's the function that returns an object reference. It's fully encapsulated so you can just drop it into any project you need and it returns a reference to that object.

plain text version

VBA:

Function GetFSO() As Object
' returns a reference to the Scripting.FileSystemObject to the calling sub
On Error Resume Next
Set GetFSO = GetObject(, "Scripting.FileSystemObject")
On Error GoTo 0
If GetFSO Is Nothing Then
Set GetFSO = CreateObject("Scripting.FileSystemObject")
End If
End Function

Then we'll use a For Each Loop, setting an object reference to each mailitem in turn. There's a loop-within-a-loop, where we loop through the attachments collection for each mailitem and save them to that temp folder mentioned earlier.

In order to attach files to the newly created email from our desktop folder, a Do Loop is used to get successive filenames, and the Add Method of the Attachments Collection adds them to the message. At this point, you can do whatever you want with the email; I chose to use the Display Method to show the email, so I can type in the recipient(s), subject, etc. If you always send the attachments to the same place, you can pre-fill this information and use the Send Method instead.

Enjoy,
JP

Share and Enjoy: