Help needed with changes to save attachments to folder code

[Clorox]

Hi everyone,

I'm looking to modify the below code so that when any message (with an attachment) is added to ANY subfolder of "Personal", attachments are saved to a specific folder. However, I'm also planning to make it so that each subfolder (when an e-mail is added) saves the attachment to a folder on my network that is related to the specific subfolder.

For the sake of example, let's assume that everytime I get an e-mail with a PDF invoice from company A, I drag the e-mail to subfolder "Company A" (In "Personal") and the PDF is saved to the folder for company A (Let's call it G:\Company A, Inc.\ on my team's network drive. If the e-mail has an invoice from company B, I drag the e-mail to subfolder "Company B" (Also in "Personal") and the e-mail is saved to folder B on the team's network drive. Ideally, I'd like to use each folders "Description" Property to contain the relevant part of the folder root on the network drive so that no extra coding needs to be done if I add folders to my PST and to the network drive. I'd also eventually like to be able to have the macro ask for a letter "code" that will further enhance the folder location on the network drive so that it says "What type of file is this?", at which point I can type "I" for invoice, "C" for correspondence, etc., which will save the file to G:\Company A, Inc. (which is in the description property of the subfolder "Company A")\Invoices.

Does any of that make sense? I realize that this is an ambitious undertaking, and although I am well-versed in Excel VBA, Outlook is an entirely new world to me.

Thanks for your help!!!

P.S. You can ignore the "Print if Excel" code. I probably won't use that part.

'########################################################################## #####
'### Module level Declarations
'expose the items in the target folder to events
Option Explicit
Dim WithEvents TargetFolderItems As Items
'set the string constant for the path to save attachments
Const FILE_PATH As String = "C:\Temp\"



'########################################################################## #####
'### this is the Application_Startup event code in the ThisOutlookSession module
Private Sub Application_Startup()
'some startup code to set our "event-sensitive" items collection
Dim ns As Outlook.NameSpace
Set ns = Application.GetNamespace("MAPI")
Set TargetFolderItems = ns.Folders.Item( _
"Personal").Folders.Item("TestFolder").Items

'.Item("TestFolder")
End Sub

'########################################################################## #####
'### this is the ItemAdd event code
Sub TargetFolderItems_ItemAdd(ByVal Item As Object)
'when a new item is added to our "watched folder" we can process it
Dim olAtt As Attachment
Dim i As Integer

If Item.Attachments.Count > 0 Then
For i = 1 To Item.Attachments.Count
Set olAtt = Item.Attachments(i)
'save the attachment
olAtt.SaveAsFile FILE_PATH & olAtt.FileName

'if its an Excel file, pass the filepath to the print routine
If UCase(Right(olAtt.FileName, 3)) = "XLS" Then
PrintAtt (FILE_PATH & olAtt.FileName)
End If
Next
End If

Set olAtt = Nothing

End Sub

'########################################################################## #####
'### this is the Application_Quit event code in the ThisOutlookSession module
Private Sub Application_Quit()

Dim ns As Outlook.NameSpace
Set TargetFolderItems = Nothing
Set ns = Nothing

End Sub

'########################################################################## #####
'### print routine
Sub PrintAtt(fFullPath As String)

Dim xlAPP As Excel.Application
Dim wb As Excel.Workbook

'in the background, create an instance of xl then open, print, quit
Set xlAPP = CreateObject("Excel.application")
Set wb = xlAPP.Workbooks.Open(fFullPath)
wb.PrintOut
xlAPP.Quit

'tidy up
Set wb = Nothing
Set xlAPP = Nothing

End Sub