Help needed with changes to save attachments to folder code

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

Hi and welcome to VBAX :hi:

This make sense, we just need to tweak to the code a bit...

At the moment, the startup code sets one set of folderitems to a variable declared WithEvents and we use the Item_Add event to trigger saving the attachment.

To modify this to your specification, you should create a class that defines an event enabled set of items that behaves accordingly (on event Item_Add, save attachments to path defined in parent folder description), so create a class module named "cItems" and insert the following code[VBA]Option Explicit

Public WithEvents folderitems As Items

Sub Init(i As Items)
Set folderitems = i
End Sub

Private Sub Class_Terminate()
Set folderitems = Nothing
End Sub

Private Sub folderitems_ItemAdd(ByVal Item As Object)

Dim a As Attachment
For Each a In Item.Attachments
a.SaveAsFile Item.Parent.Description & a.FileName
Next a

End Sub[/VBA]Now, in the Application_Start code, instead of setting one folder to watch, loop though each sub-folder in "Personal", create an instance of the class, initialize it (passing its items and setting them to the WithEvents variable) and add the class to a collection (to hold them for the duration of the session)[VBA]'variable to define each set of folder items as a custom class
Dim objFolderItems As cItems
'collection to hold the classes for the duration of the session
Dim colFolderItems As New Collection

Private Sub Application_Startup()
'some startup code to set our "event-sensitive" items collection
Dim ns As Outlook.NameSpace
Dim f 'each folder

Set ns = Application.GetNamespace("MAPI")

For Each f In ns.Folders.Item("Personal Folders").Folders
Set objFolderItems = New cItems
objFolderItems.Init f.Items
colFolderItems.Add objFolderItems
Next f

End Sub[/VBA]And that should be it for stage 1 - I think it might be worth checking thats how you want it before we add anything else. Don't forget to ad the filepath to each folder description (with a trailing "\")

Hi Killian,

Thank you so much for your help. For some reason the above code gives me the following error in Application_Startup:

Compile Error "User-defined type not defined" The error is specifically on the

New cItems

area of the line

Set objFolderItems = New cItems

Your code is pasted exactly as in your above post (the only difference is I've changed my personal folder name to match the folder I'm currently using).

I'm not sure why this is the case, but perhaps you might have an idea.

Thanks!

Did you name your class module "cItems"?

Quote:

---

Originally Posted by Killian

Did you name your class module "cItems"?

---

You're too good. It works now.

Hi Killian,

Just wanted to update you on some progress I made:

I threw in an inputbox to ask where the file should be saved (In this case, I'm starting out with Onshore vs. Offshore, because I'm actually talking about investment funds, not companies per se). I actually had to use the WebViewURL property of each folder as well to specify a secondary folder location, because the Offshore folder locations are not subfolders but rather a completely different folder with it's own name (although in outlook On/Off documents they all go into the same folder in my PST file if that makes sense) I'll also be adding another input box that asks what type of document it is, which will depend on whether a value was actually entered in the first inputbox. This will allow me to hit "Esc" at the first inputbox in case it's an e-mail that contains an attachment I don't care to save (sometimes attachments have pictures and whatnot that don't need to be archived).

One other quick question and I promise I'll leave you alone:

Let's say I have more than one .pst file (but not EVERY .pst) with subfolders that should receive the ItemAdd Action for e-mails with attachments. Is there an easy way for me to alter the class module to account for this?

Thanks so much for everything!!!

Private Sub folderitems_ItemAdd(ByVal Item As Object)
Dim a As Attachment
Dim OnOff As String

OnOff = InputBox("Type On for Onshore or Off for Offshore")
If OnOff = "On" Then
For Each a In Item.Attachments
a.SaveAsFile Item.Parent.Description & a.FileName
Next a
End If

If OnOff = "Off" Then
For Each a In Item.Attachments
a.SaveAsFile Item.Parent.WebViewURL & a.FileName
Next a
End If

End Sub

Excellent, we like progress...

Adding more PST files just involves doing loop in the App_satrtup routine fro each one. so if I have two PST files with Outlook folder names:
"Personal Folders"
and
"Personal Folders 2"
I'd have two loops[VBA]For Each f In ns.Folders.Item("Personal Folders").Folders
Set objFolderItems = New cItems
objFolderItems.Init f.Items
colFolderItems.Add objFolderItems
Next f

For Each f In ns.Folders.Item("Personal Folders 2").Folders
Set objFolderItems = New cItems
objFolderItems.Init f.Items
colFolderItems.Add objFolderItems
Next f[/VBA]Now about these other options...

I don't want to overcomplicate things, but input boxes are going to be a pain in the a$$. First, you have to type and nobody likes to do that if they don't need to. Second, you have to type accurately, or it won't do anything.

I would suggest a userform would be a better approach. It can contain options for the On/Offshore and the type (invoice, communication, etc).
And you also want the option to cancel it for attachments you don't want to save.
Now, I did say it might get complicated, for which I apologise in advance, but we should be able to work through it, so here goes...

The class code still needs to loop through each attachment in the mail item, but instead of doing the save here, we can call a userform, pass it a reference to the attachment and let the form do the rest.
So now that class routine looks like this[VBA]Private Sub folderitems_ItemAdd(ByVal Item As Object)
Dim a As Attachment

For Each a In Item.Attachments
UserForm1.AttachedFile = a
UserForm1.Show
Next a
End Sub[/VBA]Now I realise that a userform doesn't normally have an "AttachedFile" property, but a userform is just another class module that behaves in a certain way, so we can write our own property, so the top of my userform code looks like this[VBA]'module level variable for the attchment
Private myAttachment As Attachment

Property Let AttachedFile(a As Attachment)
'this property is passed for each attachment from
'the calling class cItems so we have a reference
'to each attachment the form is dealing with
Set myAttachment = a
'I have a label "lblAttName" to display the
'file we're currently working with
lblAttName.Caption = myAttachment.FileName
End Property[/VBA]On my form, I have a pair of option buttons to choose between On and Off shore and a combobox that can contain all the file types which is populated when the form initializes[VBA]Private Sub UserForm_Initialize()
'a combobox called "cboAttType" for each of the file types
With cboAttType
.AddItem "Invoice"
.AddItem "Communication"
.ListIndex = 0
End With
End Sub[/VBA]After the initialize event, the property will be set, so we will have the filename in the label and an attachment variable set up and ready to use.

A cancel button can just unload the form - that attachment will be skipped.

An Ok button can do the save:
The optionbutton value can determine if the description or the WebViewURL is used in the file save path.
The combobox value can determine the next part of the filepath (these values should match the corresponding folder names) and then its finished off with the attachment name as before[VBA]Private Sub cmdOK_Click()

Dim strPathPrefix As String

If Me.optOn Then 'OnShore
strPathPrefix = Item.Parent.Description
Else 'OffShore
strPathPrefix = Item.Parent.WebViewURL
End If
myAttachment.SaveAsFile strPathPrefix & cboAttType.Value & "\" & myAttachment.FileName

End Sub[/VBA]And that should do it.
I hope... I'll be honest, I haven't tested it because I'm too lazy to set up the folders and it's nearly time for me to change locations. I'll check in later to see how you get on.
And I've attached the userform I did to avoid confusion over control names

Hi Killian, I'm making progress and I truly thank you for your insight. My form has the following, and I hope this makes sense:

A Label called "lblAttName"
A Combobox called "cboAttType"
A Command Button called "cmdOk"
An Option Button called "OptOn"

Is that correct?

I copied your code in, but I seem to be getting the following:

Run-Time Error 424 Object Required. It is highlighting the following:

strPathPrefix = Item.Parent.WebViewURL

[VBA]
Private Sub cmdOK_Click()
Dim strPathPrefix As String

If Me.OptOn Then 'OnShore
strPathPrefix = Item.Parent.Description
Else 'OffShore
strPathPrefix = Item.Parent.WebViewURL
End If
myAttachment.SaveAsFile strPathPrefix & cboAttType.Value & "\" & myAttachment.FileName

End Sub
[/VBA]

Hopefully I'm following everything right. The box does indeed pop up properly, but regardless of the selection I get this error, and the value of strPathPrefix is "" when I scroll over it.

Thanks for your help...

Ahh yes, I see the problem :doh:

The "Item" is out of scope - we need to pass it to the userform from the class in the same way we did the attachment. Perhaps it would be better to pass the folder...
Class code:[VBA]For Each a In Item.Attachments
UserForm1.AttachedFile = a
UserForm1.SourceFolder = Item.Parent
UserForm1.Show
Next a[/VBA]and in the form, another variable and property:[VBA]Private myFolder As Object

Property Let SourceFolder(f As Object)
Set myFolder = f
End Property[/VBA]now we can refer to the myFolder variable when initializing the string.
Also, I had an "optOff" option button for Offshore and it would be better to explicitly check which of the two is selected[VBA]If Me.optOn Then 'OnShore
strPathPrefix = myFolder.Description
ElseIf Me.optOff Then 'OffShore
strPathPrefix = myFolder.WebViewURL
End If[/VBA]And to be safe, in the form_initialze code you should set one of those option buttons to true - if neither is selected, we'll get an empty string again

Hopefully, that's got it - I'll try and test it tomorrow if there are any problems

Killian,

This works perfectly!!! Thank you so much for your help! I also added an "Unload Me" At the end of the cmdOK_Click Private Sub so that the userform disappears after the click (it didn't before).

One last thing - I promise I won't ask for any more. Do you have a suggestion to make it so that for certain folders in a PST (perhaps subfolders that have a certain property set such as the ShowItemCount Property = olShowTotalItemCount whereas all others would have that option box toggled to the other option, which I believe is olShowUnreadItemCount), if there is no attachment, we load the form anyway to save the .msg file instead?

The purpose for this is as follows: Occasionally, let us assume that certain companies (Say A and C, but not send us the "invoice" but it's not in an attachment, it's just in the text of the e-mail. Then, for these particular company folders, regardless of whether the item has an attachment, we load the userform and save the attachment or .msg (but only the .msg if there is no attachment).

I hope that makes sense.

FYI - I've contributed $30 to the forums for all of your help. I really appreciate it, and if we can nail down this last bit I promise you won't hear from me for a while.

Firstly, let me thank you on behalf of VBAX for the donation - very much appreciated :beerchug:
Perhaps more importantly, you're welcome to ask as much as you like! All the regulars get a kick out of helping people use VBA to get the most out of their investment in MS Office and we all learn a little more ourselves along the way. Real-world problems are the best way for me to develop my own ability to find real-world solutions, so everyone's a winner!

And speaking of solutions...
At the moment, the class dictates that when a mail item arrives in a folder, we get the userform showing for each attachment, so we could just say that if there are no attachments, we want the option to show the form to save the message.
The most efficient way, i think, would be to first modify the existing code to pass the mail item to the form, intstead of the Item.Parent (folder).
That way we can still derive the path in the OK_click code with something like[VBA]strPathPrefix = myItem.Parent.Description[/VBA]and we'll have the Mail item available to save if we want.
So, change the class code:[VBA]For Each a In Item.Attachments
UserForm1.AttachedFile = a
UserForm1.SourceItem = Item
UserForm1.Show
Next a[/VBA]modify the property(previously SourceFolder):[VBA]Private myItem As MailItem

Property Let SourceItem(i As MailItem)
Set myItem = i
End Property[/VBA]and in the OK_click event:[VBA]If Me.optOn Then 'OnShore
strPathPrefix = myItem.Parent.Description
ElseIf Me.optOff Then 'OffShore
strPathPrefix = myItem.Parent.WebViewURL
End If[/VBA]Now would be a good time to test it still works...

Now that's settled, we can revisit the logic in the class event to deal with mails with no attachments[VBA]If Item.Attachments.Count > 0 Then
For Each a In Item.Attachments
UserForm1.AttachedFile = a
UserForm1.SourceItem = Item
UserForm1.Show
Next a
Else ' no attachments
UserForm1.SourceItem = Item
UserForm1.Show
End If[/VBA]we can check the attachment property next - if it's empty, we can populate the label accordingly[VBA]Property Let AttachedFile(a As Attachment)
Set myAttachment = a
If a Is Nothing Then
lblAttName.Caption = "Mail item"
Else
lblAttName.Caption = myAttachment.FileName
End If
End Property[/VBA]and finally, back to the OK_click event to check whether we need to save a mail item or an attachment - we could just take a look at the label text to see which it is[VBA]If lblAttName.Caption = "Mail item" Then
myItem.SaveAs strPathPrefix & cboAttType.Value & "\" & myItem.FileName
Else
myAttachment.SaveAsFile strPathPrefix & cboAttType.Value & "\" & myAttachment.FileName
End If[/VBA]I realise I've side-stepped the issue of only applying this to certain folders - you can always cancel out of any save operation (a cancel button with "Unload Me" would be good for this) but if you need to, you can just add that criteria to the class event, cahnging the Esle to ElseIf <criteria to chack>[VBA]ElseIf Item.Parent.ShowItemCount = olShowTotalItemCount Then ' no attachments[/VBA]
So that should refine things a little further. Once again I'll leave the testing in your capable hands and keep my fingers crossed : pray2:

Thanks again for your help Killian.

I'll try this on Monday morning. Can you also take a look at the below code and let me know what you think?

I decided to throw in an "Overwrite file?" Popup in the event that the file already exists. This is in case certain attachments from time periods have the same name. I'm wondering the best way is to add a digit to the end of the file so that there is no overwrite, but I still want it to ask me if the file should be overwritten (if that makes sense).

The relevant part of the code is below. You'll also note that I added in a new combobox called "ComboMonth". This is used so that if someone is filing a monthly balance, it automatically saves with a filename of the ComboMonth Value (And it also pulls the extension information from the attachment filename so that it saves as the correct type). My issue is that this just adds "2" to the end of the file if you say "no" to overwrite file. The problem is that if, hypothetically, 3 balances were received in a single month, this would overwrite the 2nd file, which would be bad. Of course, I could continue If Then statements up to say "5" on the end which would solve the problem, but I assume that there is a better way to loop it.

Here's the code:
[vba]
If cboAttType.Value = "Cap Acct Stmts" Then
myAttachment.SaveAsFile strPathPrefix & cboAttType.Value & "\" & ComboMonth.Value & Right(AttExtension, 4)
If Len(Dir(strPathPrefix & cboAttType.Value & "\" & ComboMonth.Value & Right(AttExtension, 4))) > 0 Then
Resp = MsgBox("Overwrite file?", vbYesNo)
End If
If Resp = vbYes Then
myAttachment.SaveAsFile strPathPrefix & cboAttType.Value & "\" & ComboMonth.Value & Right(AttExtension, 4)
Else
myAttachment.SaveAsFile strPathPrefix & cboAttType.Value & "\" & ComboMonth.Value & "2" & Right(AttExtension, 4)
End If

Else
myAttachment.SaveAsFile strPathPrefix & cboAttType.Value & "\" & myAttachment.FileName
Unload Me
End If
End If
Unload Me

End Sub
[/vba]

Another interesting thing I noticed for which I was actually able to make a workaround. When I receive a fax in my outlook, I see the attachment as well as small picture files for as many pages as there are in the fax. The filetype is "Picture (Device Independent Bitmap)". Anyway, the macros fail when it encounters these because Outlook can't save these (I don't want it to anyway, otherwise I'd have duplicate attachments since everything I need is in the .dcx file that's in the e-mail). The point is, I figured out a workaround, but it's a pretty crude one but I figured I'd show you what I did anyway so that you can get a good laugh at my (lack of) skills.

In the Userform1 area I put the following (The beginning part is yours, I just modified it since when the picture files are loaded as the attachment, the code sets myattachment = "Picture (Device Independent Bitmap)":
[vba]
Property Let AttachedFile(a As Attachment)
'this property is passed for each attachment from
'the calling class cItems so we have a reference
'to each attachment the form is dealing with
Set myAttachment = a
'I have a label "lblAttName" to display the
'file we're currently working with
If myAttachment = "Picture (Device Independent Bitmap)" Then
lblAttName.Caption = "FaxPicture"
Else
lblAttName.Caption = myAttachment.FileName
End If
End Property
[/vba]

And in the cmdOK_click () sub I put

[vba]
If lblAttName.Caption = "FaxPicture" Then
Unload Me
[/vba]

Then I put the following modified code in the folderitems_ItemAdd code:

[vba]
Property Let AttachedFile(a As Attachment)
'this property is passed for each attachment from
'the calling class cItems so we have a reference
'to each attachment the form is dealing with
Set myAttachment = a
'I have a label "lblAttName" to display the
'file we're currently working with
If myAttachment = "Picture (Device Independent Bitmap)" Then
lblAttName.Caption = "FaxPicture"
Else
lblAttName.Caption = myAttachment.FileName
End If
End Property
[/vba]

It may be an ugly way to do it, but now, when I file an e-mail with a fax away that has these junk picture attachments on it as well, it Exits the sub once it hits one of the junk files I don't need.

I just thought I would share some of this with you so that you know I'm not just mooching, but trying to add some of my own ideas in here as well.

Thanks for everything Killian.

Ignore the above - I realize that this mislabels every attachment as "Mail Item" I wil try to figure out how to fix this and post back.

I fixed it with this instead - It seems to work (I think).

[VBA]
Property Let SourceItem(i As MailItem)
Set myItem = i
If i.Attachments.Count = 0 Then
lblAttName.Caption = "Mail item"
End If
End Property
Property Let AttachedFile(a As Attachment)
'this property is passed for each attachment from
'the calling class cItems so we have a reference
'to each attachment the form is dealing with
Set myAttachment = a
'I have a label "lblAttName" to display the
'file we're currently working with
If myAttachment = "Picture (Device Independent Bitmap)" Then
lblAttName.Caption = "FaxPicture"
Else
lblAttName.Caption = myAttachment.FileName
End If
End Property
[/VBA]

Hi again,

Well you seem to have got the idea with managing properties but I'm not so sure it's the best place to handle this...
The first bit of code that's kicked off in this process is the class event, where each attachment is handled in turn, so I suggest that you filter out the unwanted attachments there[VBA]Dim a As Attachment
If Item.Attachments.Count > 0 Then
For Each a In Item.Attachments
If Not a = "Picture (Device Independent Bitmap)" Then
UserForm1.AttachedFile = a
UserForm1.SourceItem = Item
UserForm1.Show
End If
Next a
Else ' no attachments
UserForm1.SourceItem = Item
UserForm1.Show
End If[/VBA]Note that by not specifying a property of "a", the object's default property will be returned, which I'm thinking must be "DisplayName" (?). The point being that outlook isn't actually clever enough to know what type of file its looking at, its just reading a property set in the file, so I think it's concievable that this might not always set to "Picture (Device Independent Bitmap)" - this might depend on the fax sending software.
This may never be an issue, but it's worth knowing the limitations of the code in case something "wierd" happens further down the line.

If I get the chance a bit later, I hope to get round to assembling all this code and testing it, so I can take a look at the File overwriting scenario...

OK, i've finally got round to getting this code running...

So, with the file overwrite situation - you've come up with a good way of dealing with it in one scenario (one file alradry exists) so we can extend that by looping the filename check "Dir(path) > 0" and modifying the file name with a counter thats increments with the loop.

As with your code, I've set up some variables to hold the path+filename and the file extension so the counter variable can be inserted - also I put this index in brackets.

Now I wasn't clear on whether this check was being done in all cases or just in the case where the Monthly balances are being saved (I haven't added that to my version) but I'm sure you get the idea...[VBA]Private Sub cmdOK_Click()

Dim strPathPrefix As String
Dim strFullPathAndName As String
Dim strPathAndNameNoExt As String
Dim strFileExt As String
Dim i As Long
Dim Resp As Integer

If Me.optOn Then 'OnShore
strPathPrefix = myItem.Parent.Description
ElseIf Me.optOff Then 'OffShore
strPathPrefix = myItem.Parent.WebViewURL
End If

strFullPathAndName = strPathPrefix & cboAttType.Value & "\" & myAttachment.FileName
strFileExt = "." & Right(strFullPathAndName, Len(strFullPathAndName) - InStrRev(strFullPathAndName, "."))
strPathAndNameNoExt = Left(strFullPathAndName, InStrRev(strFullPathAndName, ".") - 1)

If Len(Dir(strFullPathAndName)) > 0 Then
Resp = MsgBox("Overwrite file?", vbYesNo)
End If
If Resp = vbYes Then
i = 2
Do
strFullPathAndName = strPathAndNameNoExt & "(" & i & ")" & strFileExt
i = i + 1
Loop Until Len(Dir(strFullPathAndName)) = 0
End If

myAttachment.SaveAsFile strFullPathAndName
Unload Me

End Sub[/VBA]

James,

Thanks for your PM. I actually never saw Killian's kind addition regarding the loop, so I'm sure you could use that as well. Either way, here is my code for the Userform part

[VBA]'module level variable for the attchment
Private myAttachment As Attachment
Private myFolder As Object
Private myItem As MailItem

Property Let SourceItem(i As MailItem)
Set myItem = i
If i.Attachments.Count = 0 Then
lblAttName.Caption = "Mail item"
End If
End Property
Property Let AttachedFile(a As Attachment)
'this property is passed for each attachment from
'the calling class cItems so we have a reference
'to each attachment the form is dealing with
Set myAttachment = a
'I have a label "lblAttName" to display the
'file we're currently working with
If myAttachment = "Picture (Device Independent Bitmap)" Then
lblAttName.Caption = "FaxPicture"
Else
lblAttName.Caption = myAttachment.FileName
End If
End Property

Private Sub CheckBox1_Click()
If CheckBox1.Enabled = True Then
OptNameBox.Value = ComboYear.Value & "-" & ComboMonth.Value & " "
Else
OptNameBox.Value = ""
End If
End Sub

Private Sub ComboMonth_Change()
End Sub
Private Sub ComboYear_Change()
End Sub
Private Sub FileType_Change()
If FileType.Value = "FileType" Then
OptNameBox.Value = ""
Else
OptNameBox.Value = ComboYear.Value & "-" & ComboMonth.Value & " " & FileType.Value
End If
End Sub
Private Sub OptNameBox_Change()
End Sub
Private Sub OptOn_Click()
End Sub
Private Sub UserForm_Initialize()
'a combobox called "cboAttType" for each of the file types
With OptOn = True
End With
With FileType
.AddItem "FileType"
.AddItem "Report"
.AddItem "Letter"
.AddItem "Exposure"
.AddItem "Performance"
.AddItem "Commentary"
.Value = "FileType"
.ListIndex = 0

End With

With cboAttType
.AddItem "Cap Acct Statements"
.AddItem "Financials"
.AddItem "Investor Reporting"
.AddItem "Performance"
.AddItem "Due Diligence"
.AddItem "Correspondence"
.AddItem "Wires"
.AddItem "Legal"
.AddItem "Manager Materials"
.ListIndex = 0
End With

With ComboMonth
.AddItem "05"
.AddItem "04"
.AddItem "03"
.AddItem "02"
.AddItem "01"
.AddItem "12"
.AddItem "11"
.AddItem "10"
.AddItem "09"
.AddItem "08"
.AddItem "07"
.AddItem "06"
.ListIndex = 0
.Value = "05"
End With
With ComboYear
.AddItem "2006"
.AddItem "2005"
.AddItem "2004"
.AddItem "2003"
.Value = "2006"
End With
With ComboFin
.AddItem "K1"
.AddItem "FS"
.Value = "FS"
End With

End Sub
Private Sub cmdOK_Click()
Dim strPathPrefix As String
Dim SavedFileName As String
Dim SubjectText As String
If lblAttName.Caption = "Mail item" Then
SubjectText = myItem.Subject
If (SubjectText Like "*:*") Or (SubjectText Like "*>*") Or (SubjectText Like "*;*") _
Or (SubjectText Like "*=*") Or (SubjectText Like "*\*") Or (SubjectText Like "*<*") _
Or (SubjectText Like "*>*") Or (SubjectText Like "*+*") Or (SubjectText Like "*]*") Then
' Or (SubjectText Like "*[*") <---- IT DOESN'T SEEM TO LIKE THIS
Resp = MsgBox("Invalid Characters in Subject", vbOKOnly)
Unload Me
Exit Sub
End If
Else
SavedFileName = myItem.Subject
End If
If lblAttName.Caption <> "Mail item" Then
SavedFileName = myAttachment.FileName
End If
If OptNameBox.Value = "" Then
Else
SavedFileName = OptNameBox.Value
End If
If Me.OptOn Then 'OnShore
strPathPrefix = myItem.Parent.Description
ElseIf Me.OptOff Then 'OffShore
strPathPrefix = myItem.Parent.WebViewURL
End If
If lblAttName.Caption = "FaxPicture" Then
Unload Me
Else
End If

If cboAttType.Value = "Financials" Then
myAttachment.SaveAsFile strPathPrefix & cboAttType.Value & "\" & ComboYear.Value & " " & ComboFin.Value & Right(myAttachment.FileName, 4)
Unload Me
Exit Sub
End If


If lblAttName.Caption = "Mail item" And cboAttType.Value <> "Cap Acct Statements" Then
myItem.SaveAs strPathPrefix & cboAttType.Value & "\" & SavedFileName & " " & Format(myItem.ReceivedTime, "mmddyy") & ".msg"
Unload Me
Exit Sub
End If

If lblAttName.Caption = "Mail item" And cboAttType.Value = "Cap Acct Statements" Then
If Len(Dir(strPathPrefix & cboAttType.Value & "\" & ComboYear.Value & "-" & ComboMonth.Value & ".msg")) > 0 Then
Resp = MsgBox("Overwrite file?", vbYesNo)
If Resp = vbYes Then
myItem.SaveAs strPathPrefix & cboAttType.Value & "\" & ComboYear.Value & "-" & ComboMonth.Value & ".msg"
Unload Me
Else
myItem.SaveAs strPathPrefix & cboAttType.Value & "\" & ComboYear.Value & "-" & ComboMonth.Value & Format(myItem.ReceivedTime, " hhnnss") & ".msg"
Unload Me
End If
Else
myItem.SaveAs strPathPrefix & cboAttType.Value & "\" & ComboYear.Value & "-" & ComboMonth.Value & ".msg"
Unload Me
End If
Unload Me
Exit Sub
End If



If lblAttName.Caption <> "Mail Item" And cboAttType.Value = "Cap Acct Statements" Then
If Len(Dir(strPathPrefix & cboAttType.Value & "\" & ComboYear.Value & "-" & ComboMonth.Value & Right(myAttachment.FileName, 4))) > 0 Then
Resp = MsgBox("Overwrite file?", vbYesNo)
If Resp = vbYes Then
myAttachment.SaveAsFile strPathPrefix & cboAttType.Value & "\" & ComboYear.Value & "-" & ComboMonth.Value & Right(myAttachment.FileName, 4)
Else
myAttachment.SaveAsFile strPathPrefix & cboAttType.Value & "\" & ComboYear.Value & "-" & ComboMonth.Value & Format(myItem.ReceivedTime, "hhnnss") & Right(myAttachment.FileName, 4)
End If
Else
myAttachment.SaveAsFile strPathPrefix & cboAttType.Value & "\" & ComboYear.Value & "-" & ComboMonth.Value & Right(myAttachment.FileName, 4)
End If
Unload Me
Exit Sub
End If

If lblAttName.Caption <> "Mail Item" And cboAttType.Value <> "Cap Acct Statements" Then
myAttachment.SaveAsFile strPathPrefix & cboAttType.Value & "\" & SavedFileName & Right(myAttachment.FileName, 4)
Unload Me
Exit Sub
End If

End Sub
Private Sub cmdCancel_Click()
Unload Me
End Sub
[/VBA]

Here is my code for the cItems class module:

[VBA]Option Explicit

Public WithEvents folderitems As Items

Sub Init(i As Items)
Set folderitems = i
End Sub

Private Sub Class_Terminate()
Set folderitems = Nothing
End Sub

Private Sub folderitems_ItemAdd(ByVal Item As Object)
Dim a As Attachment
If Item.Attachments.Count > 0 Then
For Each a In Item.Attachments
UserForm1.AttachedFile = a
UserForm1.SourceItem = Item
If UserForm1.lblAttName.Caption = "FaxPicture" Then
Exit Sub
Else
UserForm1.Show
End If
Next a
ElseIf Item.Parent.ShowItemCount = olShowTotalItemCount Then ' no attachments
UserForm1.SourceItem = Item
UserForm1.Show
Else
Exit Sub
End If
End Sub
[/VBA]

And finally, here is my code for ThisOutlookSession:
[VBA]
Public FaxAtt As String
'variable to define each set of folder items as a custom class
Dim objFolderItems As cItems
'collection to hold the classes for the duration of the session
Dim colFolderItems As New Collection

Private Sub Application_Startup()
'some startup code to set our "event-sensitive" items collection
Dim ns As Outlook.NameSpace
Dim f 'each folder

Set ns = Application.GetNamespace("MAPI")

For Each f In ns.Folders.Item(".FAGE").Folders
Set objFolderItems = New cItems
objFolderItems.Init f.Items
colFolderItems.Add objFolderItems
Next f

For Each f In ns.Folders.Item(".FASS").Folders
Set objFolderItems = New cItems
objFolderItems.Init f.Items
colFolderItems.Add objFolderItems
Next f

For Each f In ns.Folders.Item(".FATG").Folders
Set objFolderItems = New cItems
objFolderItems.Init f.Items
colFolderItems.Add objFolderItems
Next f

For Each f In ns.Folders.Item(".FAVC").Folders
Set objFolderItems = New cItems
objFolderItems.Init f.Items
colFolderItems.Add objFolderItems
Next f
End Sub
[/VBA]

Hopefully that helps, but let me know if you need anything.