Automatically downloading multiple Attachments to different folders.

Hello all, long story short is that at my job I get around 30-40 emails every morning in Outlook 2010 with account statistics for different accounts. I am currently running this script that I found through pixelchef.net to download the attachments automatically to a folder on my desktop.

Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
saveFolder = "C:\"
For Each objAtt In itm.Attachments
objAtt.SaveAsFile saveFolder & "\" & objAtt.DisplayName
Set objAtt = Nothing
Next
End Sub

I like what this script does except for that it dumps all the attachments into the same folder so I still have to manually move them into specific folders for the accounts. I am wondering if there is a way I can change this script so that I can have it download the files to their specific folders based on either the the title of the email or the name of the file? All the file names are the same except for the name of the account. Example "Calls-[insert account name]-[Insert Date].pdf".

I am trying to learn Outlook VBA code but the quicker I can find out how to do this the better. Any help would be greatly appreciated.

If you have the folder separator included in the savefolder definition, you don't also need it in the saveas string
If the filenames match your description with blocks separated by hyphens then the following should save the attachments in the subfolder associated with the account name in the filename. If the account folder may not exist you must create it - see the CreateFolders function. This will create an missing folder.

Code:

---

Option Explicit

Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
    saveFolder = "C:\"
    For Each objAtt In itm.Attachments
        If InStr(1, objAtt.fileName, "-") > 0 Then
            saveFolder = saveFolder & Split(objAtt.fileName, "-")(1) & "\"
            CreateFolders saveFolder
        End If
        objAtt.SaveAsFile saveFolder & objAtt.DisplayName
        Set objAtt = Nothing
    Next
End Sub

Private Function CreateFolders(strPath As String)
'An Office macro by Graham Mayor - www.gmayor.com
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
Dim oFSO As Object
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    vPath = Split(strPath, "\")
    strPath = vPath(0) & "\"
    For lngPath = 1 To UBound(vPath)
        strPath = strPath & vPath(lngPath) & "\"
        If Not oFSO.FolderExists(strPath) Then MkDir strPath
    Next lngPath
lbl_Exit:
    Set oFSO = Nothing
    Exit Function
End Function

---

Thank you, Sorry but I am still learning the coding procedure.

So If I want to have this code run and distribute these files into their 30 individual sub folders do I Copy and past the If function multiple times and change the filename "-" and Save folder "\"?

Or do I copy and past the function starting at "Dim objAtt..." and past it after the "Next" function?

You just copy and paste the code as written. It replaces your original code.

It works on the premise that your attachments have the name format - "Calls-[insert account name]-[Insert Date].pdf", which comprises three sections separated by hyphens. It uses the middle section (the account name) to determine where to file the attachments and files them in a sub folder (with that account name) of 'saveFolder' which from your original code is "C:\". Save folder can be any path you define and, as long at the root of that path is available, the process will create any required folder that doesn't exist.

Attachments that don't match that format are saved in the 'saveFolder' folder. - here "C:\". Note that it is not the best idea to save in the root of the C drive so to accommodate a change from that it might be better to move the CreateFolders line outside the conditional statement e.g.

Code:

---

Public Sub saveAttachtoDisk(itm As Outlook.MailItem)     
    Dim objAtt As Outlook.Attachment
    Dim saveFolder As String
    saveFolder = "C:\"
    For Each objAtt In itm.Attachments
        If InStr(1, objAtt.fileName, "-") > 0 Then
            saveFolder = saveFolder & Split(objAtt.fileName, "-")(1) & "\"
        End If
        CreateFolders saveFolder 'move this line to here
        objAtt.SaveAsFile saveFolder & objAtt.DisplayName
        Set objAtt = Nothing
    Next
End Sub

---

The remaining code and the Createfolders function are still required.