Save attachments and send clean emails
September 28, 2008 • JP • No Comments • Rate This Article
• Links to this article
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.
' 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.
' 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.
' 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
(No Ratings Yet)
Loading ...What now?
Subscribe To The Blog
Email This Article
Follow Me On Twitter
My Facebook Page
Or just keep reading:
I'm just an average guy who writes VBA code for a living. This is my personal blog. Excel and Outlook are my thing, with a sprinkle of Access and Word here and there. Follow this space if you want to learn more about VBA. Keep Reading »
Previous Post: My Excel User Conference Experience
Next Post: Blog Maintenance
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.
——————————————
'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
——————————————
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?
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.
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.
I did some tweaks and it works…
Thanks a million!
Glad to hear it Darren!
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
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