Save attachments and send clean emails

September 28, 2008JPNo CommentsRate This ArticlenewLinks 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.

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.

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.

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

About JP
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 »

↑ Scroll to top
Previous Post:

Next Post:

8 Response(s) to Save attachments and send clean emails ↓

  1. Darren says:

    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.

    ——————————————

    Sub SaveAttachment()

        '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

    ——————————————

  2. JP says:

    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?

  3. Darren says:

    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.

  4. JP says:

    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.

  5. darren says:

    I did some tweaks and it works…

    Thanks a million!

  6. JP says:

    Glad to hear it Darren!

  7. Deepak says:

    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

  8. JP says:

    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

    If myAttachments.Count > 0 Then

Speak Your Mind

Tell us what you're thinking...

Certain comments (including first-time comments) are subject to moderation and will not appear immediately. Please view the Comment Policy for more information. To post VBA code in your comment, use tags like this: [cc lang='vb']Code goes here[/cc].




Site last updated September 2, 2010 @ 7:03 pm