Save attachments and send clean emails
Posted September 28, 2008 – 5:35 pm by JP in Outlook, VBA
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.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 | 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.
1 2 3 4 5 6 7 8 9 10 | 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.
1 2 3 4 5 6 7 8 9 10 | 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
Tags: attachments
If you enjoyed this post, make sure you 
Comments RSS
8 Responses to Save attachments and send clean emails
I'm a newbie in VB I am trying to save Outlook attachment to user's desktop with the following VB script. But it doesn't work. May I know what's wrong with the code below?
I would like to thank you in advance.
——————————————
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
'Declaration
Dim myItems, myItem, myAttachments, myAttachment As Object
Dim myOrt As String
Dim myOlApp As New Outlook.Application
Dim myOlExp As Outlook.Explorer
Dim myOlSel As Outlook.Selection
Dim strMyDesktop
Dim strDestinationFolder
Dim fso As Object
' get path of user's desktop and build a string for the destination folder
strMyDesktop = MyDesktopPath & "\"
strDestinationFolder = strMyDesktop & "Saved Attachments\"
' 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
On Error Resume Next
'work on selected items
Set myOlExp = myOlApp.ActiveExplorer
Set myOlSel = myOlExp.Selection
'for all items do...
For Each myItem In myOlSel
'point on attachments
Set myAttachments = myItem.Attachments
'if there are some...
If myAttachments.Count > 0 Then
'for all attachments do...
For i = 1 To myAttachments.Count
'save them to destination
myAttachments(i).SaveAsFile strDestinationFolder & myAttachments(i).DisplayName
Next i
'save item without attachments
myItem.Save
End If
Next
'free variables
Set myItems = Nothing
Set myItem = Nothing
Set myAttachments = Nothing
Set myAttachment = Nothing
Set myOlApp = Nothing
Set myOlExp = Nothing
Set myOlSel = Nothing
Set fso = Nothing
End Sub
——————————————
By Darren on Dec 11, 2008
What version of Office? Where are you using this code? In Outlook? If so…
1) What specifically "doesn't work"? You should step through the code and find out what specific lines are causing errors.
2) "Dim myItems, myItem, myAttachments, myAttachment As Object" should actually be "Dim myItems As Object, myItem As Object, myAttachments As Object, myAttachment As Object"
You can share the word "Dim", but not the type declaration.
2) Where is "MyDesktopPath" coming from? I assume you have another sub where you are locating the path to the desktop.
3) I assume "GetFSO" is another sub where you are setting a reference to Scripting.FileSystemObject?
By JP on Dec 11, 2008
Yes, I am using this code in MS Outlook 2003 and I have VB 6.3.
1)
- I received this error when I tried to run it: Run-time error '424′: Object required.
- I tried to step through the code and this is the line causing error:
Set fso = GetFSO
Thus I deleted this section and manually create "saved attachment" folder on my desktop. the VB ran without any error but did not save any attachment.
' 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
2) I did change it.
3) I might have used "MyDesktopPath" incorrectly. Any suggestion will be appreciated.
4) Not too sure about how to use GetFSO. Should it even exist in my code?
Thanks for your reply.
By Darren on Dec 12, 2008
Let's take it one problem at a time. The GetFSO sub is part of the above post — in your module you need to use both subs: MyDesktopPath and GetFSO. Are you sure you've pasted both subs into a standard module in Outlook?
Otherwise just replace "Set fso = GetFSO" with "Set GetFSO = CreateObject("Scripting.FileSystemObject")"
and change "strMyDesktop = MyDesktopPath & "\"" to "strMyDesktop = Environ("userprofile") & "Desktop\""
Let me know if that works; if not, use the contact form and email me your entire code.
By JP on Dec 14, 2008
I did some tweaks and it works…
Thanks a million!
By darren on Dec 30, 2008
Glad to hear it Darren!
By JP on Dec 30, 2008
HI Glad,
Thanks for the informations that you have given here, i tried the same coding but its not executing on these two lines
"If myAttachments.Count& Then"
"myAttachments(i).SaveAsFile strDestinationFolder & myAttachments(i).DisplayName"
please suggest! thnks in advance
By Deepak on Jan 22, 2009
Have you tried stepping through the code and checking what "myAttachments" points to?
The code in darren's comment isn't posted correctly, it should be
By JP on Jan 22, 2009