Solved

Save outlook attachments from an Outlook folder to a file folder with the same name

Posted on 2010-09-02
3
284 Views
Last Modified: 2012-06-27
I need a function, which saves the attachments in the emails inside an outlook folder to a file folder on the drive with the same name. So lets say the outlook folder is named Cortina. The code looks through the folders to find if there are any files with attachments.  The following code achieves that.

So when the code realizes there is a new file with an attachment inside the folder, it will take that file and save it under c:\roberto\cortina

SO if the outlook folder was named roddick than the path would have been c:\roberto\roddick.

how can I achieve this?
Sub GoToProjectsFolder()

'Makes the "Projects" folder the active folder in the current instance of Outlook

'v1.00 28Jun2007

    Dim myolApp As Outlook.Application

    Dim mynamespace As Outlook.NameSpace

    Dim myFolder As Outlook.MAPIFolder

    Dim found As Boolean

    Dim strFolderName As String

Dim oltempitem As Object

Dim atmt As Attachment

Dim filename As String

Dim filefolder As String



    'specify the folder you are looking for

    strFolderName = "Inbox"

    

   

    Set myolApp = GetObject(, "Outlook.Application")

    Set mynamespace = myolApp.GetNamespace("MAPI")

    

    

    Set myFolder = mynamespace.Folders("Mailbox - Ruben Cortina").Folders("Clients")

    

   For i = 1 To myFolder.Folders.Count

For j = 1 To myFolder.Folders(i).Items.Count





'myFolder.Folders.Ite



'   MsgBox myFolder.Folders(i)

'myFolder.Folders (i)

   Set oltempitem = myFolder.Folders(i).Items(j)

    If myFolder.Folders(i).Items(j).Attachments.Count > 0 Then



For Each atmt In myFolder.Folders(i).Items(j).Attachments

'

'MsgBox myFolder.Folders(i).Items(j).EntryID

'

'myFolder.Folders(i).Items(j).EntryID

    

   





Next

'MsgBox oltempitem.Subject

End If



   

   Next

    

Next

    

'   For i = 1 To (mynamespace.Folders.Count)

   



    Set myolApp = Nothing

    Set mynamespace = Nothing

    

    

    

End Sub

Open in new window

0
Comment
Question by:awesomejohn19
  • 2
3 Comments
 
LVL 38

Expert Comment

by:puppydogbuddy
ID: 33596289
Have a look at the sample code at this link:
           http://www.slovaktech.com/code_samples.htm#StripAttachments

The code has a called function to add the attachments to a temp folder, which you should be able to adapt to your needs.
0
 
LVL 31

Accepted Solution

by:
Helen_Feddema earned 500 total points
ID: 33596317
This code will do it (modify as needed for your setup):
Public Sub StoreAttsInFolder()

'Created by Helen Feddema 2-Sep-2010

'Last modified by Helen Feddema 2-Sep-2010



On Error GoTo ErrorHandler



   Dim nms As Outlook.NameSpace

   Dim ofld As Outlook.Folder

   Dim sfld As Scripting.Folder

   Dim fil As Scripting.File

   Dim fldInbox As Outlook.Folder

   Dim itm As Object

   Dim msg As Outlook.MailItem

   Dim att As Outlook.Attachment

   Dim strAttName As String

   Dim strFolderName As String

   Dim strRootFolder As String

   Dim fso As New Scripting.FileSystemObject

   Dim strFolderPath As String

   Dim strFilePath As String

   

   strRootFolder = "G:\Documents\Attachments\"

   Set nms = Application.GetNamespace("MAPI")

   Set fldInbox = nms.GetDefaultFolder(olFolderInbox)

   

   For Each ofld In fldInbox.Folders

      strFolderName = ofld.Name

      For Each itm In ofld.Items

         If itm.Class = olMail Then

            Set msg = itm

            If msg.Attachments.Count > 0 Then

               For Each att In msg.Attachments

                  'Create Explorer folder if needed

                  strAttName = att.FileName

                  strFolderPath = strRootFolder & strFolderName

                  Debug.Print "Folder path: " & strFolderPath

                  Set sfld = fso.GetFolder(strFolderPath)

                  strFilePath = strFolderPath & "\" & strAttName

                  Debug.Print "File path: "; strFilePath

                  att.SaveAsFile strFilePath

               Next att

            End If

         End If

      Next itm

   Next ofld

   

ErrorHandlerExit:

   Exit Sub



ErrorHandler:

   If Err.Number = 76 Then

      Set sfld = fso.CreateFolder(strFolderPath)

      Resume Next

   Else

      MsgBox "Error No: " & Err.Number _

         & " in StoreAttsInFolder procedure; " _

         & "Description: " & Err.Description

      Resume ErrorHandlerExit

   End If

   

End Sub

Open in new window

0
 
LVL 31

Expert Comment

by:Helen_Feddema
ID: 33596319
Also, declare the ofld variable as MAPIFolder if using a version of Outlook earlier than 2007
0

Featured Post

Windows Server 2016: All you need to know

Learn about Hyper-V features that increase functionality and usability of Microsoft Windows Server 2016. Also, throughout this eBook, you’ll find some basic PowerShell examples that will help you leverage the scripts in your environments!

Join & Write a Comment

Set OWA language and time zone in Exchange for individuals, all users or per database.
Use email signature images to promote corporate certifications and industry awards.
Get people started with the process of using Access VBA to control Excel using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Excel. Using automation, an Access application can laun…
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…

760 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

22 Experts available now in Live!

Get 1:1 Help Now