Save attachments and file email

Hello All,

I would like to know anyone knows a function that will save the attachments of email with a specific subject ("Car Mileage Claim") to the windows directory ("C:\Car_Mileage_Attachments\"), and then move the email to an outlook folder ("Car_Mileage"). I would like this to run as the email comes in, but also when outlook opens to go through and check for any new emails.

Thanks, Dommie Lama
DomiLamaAsked:
Who is Participating?
 
David LeeConnect With a Mentor Commented:
DomiLama,

The code for doing this is below.  Follow these instructions to use it.

1.  Start Outlook.
2.  Click Tools->Macro->Visual Basic Editor.
3.  If not already expanded, expand Modules and click on Module1.
4.  Copy the code below and paste it into the right-hand pane of the VB Editor.
5.  Edit the code as needed.  I placed comment lines where things need to change.
6.  Click the diskette icon on the toolbar to save the changes.
7.  Close the VB Editor.
8.  Click Tools->Macro->Security.
9.  Change the Security Level setting to Medium.
10.  Create a rule that runs when a new message arrives.  Set it to check the subject for the text you want to trigger on.  If found, set the rule to move the message to the "Car Mileage Claim" folder and to run the macro.  The order is immaterial.  The final rule should look something like this:

Apply this rule after the message arrives
with Car Mileage Claim in the subject
  and on this machine only
move it to the Car_Mileage folder
  and run Modules.SaveAttachmentsToDiskRule


Sub SaveAttachmentsToDiskRule(olkMessage As Outlook.MailItem)
    Dim olkAttachment As Outlook.Attachment, _
        objFSO As Object, _
        strRootFolderPath As String, _
        strFilename As String
    'Change the path on the following line to the folder you want the attachments save in
    strRootFolderPath = "C:\Car_Mileage_Attachments\"
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set olkSourceFolder = Application.ActiveExplorer.CurrentFolder
    If olkMessage.Attachments.Count > 0 Then
        For Each olkAttachment In olkMessage.Attachments
            strFilename = olkAttachment.FileName
            intCount = 0
            Do While True
                If objFSO.FileExists(strRootFolderPath & strFilename) Then
                    intCount = intCount + 1
                    strFilename = "Copy (" & intCount & ") of " & olkAttachment.FileName
                Else
                    Exit Do
                End If
            Loop
            olkAttachment.SaveAsFile strRootFolderPath & strFilename
        Next
    End If
    Set objFSO = Nothing
    Set olkAttachment = Nothing
    Set olkMessage = Nothing
End Sub
0
 
David LeeCommented:
Hi DomiLama,

This is possible with the combination of a rule and a macro.  If using a macro is an option, then I can post the code and instructions for both.

Cheers!
0
 
DomiLamaAuthor Commented:
Hi BlueDevilFan, yeah I think that might do the job. Can you send the code and I'll give it a go.

Thanks.
0
Free Tool: Port Scanner

Check which ports are open to the outside world. Helps make sure that your firewall rules are working as intended.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

 
Serena HsiMarketing ConsultantCommented:
Using VBA to Manage Your Outlook Email Attachments (tutorial and VBA walk-through)
http://www.fontstuff.com/outlook/oltut01.htm

Use the Rules wizard to trigger based on an email with an attachment, with "specific words" in the subject, perform a "custom action", and move the email to a "specified folder".
0
 
penlandtCommented:
I can't understand why - but this solution is not working for me.  I've tried.  The macro moves the message to the folder it should, but it does not save the attachments.  I tried putting a break point in the code so that I could step through it but it appears that macro never runs because the break point is never reached.  Any idea why?

Here's my rule:

Apply this rule after the message arrives
with New eBay Listing in the subject
  and on this machine only
move it to the Completed Messages folder
  and run Project1.SaveAttachmentsToDiskRule
  and mark it as read
Sub SaveAttachmentsToDiskRule(olkMessage As Outlook.MailItem)
    Dim olkAttachment As Outlook.Attachment, _
        objFSO As Object, _
        strRootFolderPath As String, _
        strFilename As String
    'Change the path on the following line to the folder you want the attachments save in
    strRootFolderPath = "C:\eBayListings\"
    Stop
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set olkSourceFolder = Application.ActiveExplorer.CurrentFolder
    If olkMessage.Attachments.Count > 0 Then
        For Each olkAttachment In olkMessage.Attachments
            strFilename = olkAttachment.FileName
            intCount = 0
            Do While True
                If objFSO.FileExists(strRootFolderPath & strFilename) Then
                    intCount = intCount + 1
                    strFilename = "Copy (" & intCount & ") of " & olkAttachment.FileName
                Else
                    Exit Do
                End If
            Loop
            olkAttachment.SaveAsFile strRootFolderPath & strFilename
        Next
    End If
    Set objFSO = Nothing
    Set olkAttachment = Nothing
    Set olkMessage = Nothing
End Sub

Open in new window

0
 
penlandtCommented:
Please disregard my previous post - I had forgotten to save the Project - that's why it wasn't working.  Rookie mistake ;-)
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.