0

I am trying to copy attachments from emails to a specific place on the network (Z:).
I've seen various scripts for this but what is tripping me up is the file structure.

Inbox
Drafts
Outbox
My Folder
  Employer Name
    Project Name
      Organizational Folder
      Organizational Folder
    Project Name
      Organizational Folder
      Organizational Folder
  Employer Name
    Project Name
      Organizational Folder
      Organizational Folder

Emails are going to be stored inside Organizational Folders only. These will be things like job information, approvals, etc.

I created another script that automatically creates these folders in both Outlook and on the network, so the folders will always be there, but there could be any number of Employer folders as well as any number of Project folders.

So basically attachments from "\My Folder\Employer 1\Project 2\Organizational Folder" in Outlook need to be copied to "Z:\Employer 1\Project 2\Organizational Folder".

I assume I'll have to use nested if loops to dig into each folder structure to copy the attachments.

Community
  • 1
  • 1
Aidan Vanleuven
  • 75
  • 4
  • Have a look at this answer: [How to copy Outlook mail message into excel using VBA or Macros](http://stackoverflow.com/a/12146315/973283). Most of the answer is concerned with showing what emails look like to VBA which is not relevant to your current question. At the bottom are a pair of recursive routines that will search for a folder anywhere within the hierarchy. You would need to place the PST file name before "\My Folder". – Tony Dallimore Apr 23 '16 at 09:04
  • The answer referenced by the previous comment links to an earlier answer that provides an OTT tutorial on the Outlook Object model. You might find that helpful – Tony Dallimore Apr 23 '16 at 10:57

1 Answers1

1

I'm not 100% sure I've grasped what you're trying to do but I think this will do the trick. Note - It will only work if your folder structure goes no more than 3 levels deep, if you need you can add extra levels. You could also consider using a recursive sub to search through the folders. This is untested sudocode, but it should be at least 90% of what you need.

Sub SaveOutlookAttachments()

Dim Ol As New Outlook.Application
Dim Tf As Outlook.Folder, Sf1 As Outlook.Folder, Sf2 As Outlook.Folder, Sf3 As Outlook.Folder

'Bind Fl to your top folder
Set Tf = Ol.Session.GetDefaultFolder(olFolderInbox).Folders("My Folder")
'Loop through each subfolder
For Each Sf1 In Tf.Folders
    For Each Sf2 In Sf1.Folders
        For Each Sf3 In Sf2.Folders
            'Loop through items in Sf3
            Call SaveAtt(Sf3, Tf.Name & "\" & Sf1.Name & "\" & Sf2.Name & "\" & Sf3.Name & "\")
        Next
        'Loop through items in Sf2
        Call SaveAtt(Sf2, Tf.Name & "\" & Sf1.Name & "\" & Sf2.Name & "\")
    Next
    'Loop through items in Sf1
    Call SaveAtt(Sf1, Tf.Name & "\" & Sf1.Name & "\")
Next

'Quit outlook
Ol.Quit
Set Ol = Nothing

End Sub

Sub SaveAtt(OlFolder As Outlook.Folder, SaveFolder As String)

'***Alter this***
Const MainFolder = "\\Server\Folder1\Folder2\"
'****************
Dim Mi As Outlook.MailItem
Dim Att As Outlook.Attachment
Dim FSO As New FileSystemObject

'Loop through items within the folder passed to the sub
For Each Mi In OlFolder.Items
    'Check for an attachment
    If Mi.Attachments.Count > 1 Then
        'Check if the folder exists
        If FSO.FolderExists(MainFolder & SaveFolder) = False Then FSO.CreateFolder (MainFolder & SaveFolder)
        'Save the attachments
        For Each Att In Mi.Attachments
            Att.SaveAsFile (MainFolder & SaveFolder & Att.Filename)
        Next
    End If
Next
Set FSO = Nothing

End Sub
Jason Conway
  • 116
  • 7