How to apply a Macro on multiple Outlook folders

[cowboyuser]

I have been able to create a macro to sort messages into a "sender name" subfolder, when I move the message into the parent. for instance:

1. 
   I receive a message in my inbox.
   
2. 
   I move the message into the "follow-up" folder
   
3. 
   If there is no subfolder named sender name it is created
   
   3a. The message is immediately moved into follow-up/sender name
   

The code below performs these steps perfectly. What I need to do now is apply the code to other folders. At the moment, my code sits in the "ThisOutlookSession" module, because I want it to work automatically.

My question is: How do I apply the macro to multiple subfolders of the inbox? ie:

inbox - not applied here
follow-up - applied here
team - applied here
vendors - applied here


Here is the code I have so far:

Private WithEvents Items As Outlook.Items

Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace

' set object reference to default Inbox
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set Items = objNS.GetDefaultFolder(olFolderInbox).Folders("Follow-up").Items
End Sub

Private Sub Items_ItemAdd(ByVal item As Object)
' fires when new item added to default Inbox
' (per Application_Startup)

On Error GoTo ErrorHandler

Dim Msg As Outlook.MailItem
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim targetFolder As Outlook.MAPIFolder
Dim senderName As String

' don't do anything for non-Mailitems
If TypeName(item) <> "MailItem" Then GoTo ProgramExit

Set Msg = item

' move received email to target folder based on sender name
senderName = Msg.senderName

If CheckForFolder(senderName) = False Then ' Folder doesn't exist
Set targetFolder = CreateSubFolder(senderName)
Else
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set targetFolder = objNS.GetDefaultFolder(olFolderInbox).Folders("follow-up").Folders(senderName)
End If

Msg.Move targetFolder

ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub

Function CheckForFolder(strFolder As String) As Boolean
' looks for subfolder of specified folder, returns TRUE if folder exists.
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder
Dim FolderToCheck As Outlook.MAPIFolder

Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olInbox = olNS.GetDefaultFolder(olFolderInbox).Folders("follow-up")

' try to set an object reference to specified folder
On Error Resume Next
Set FolderToCheck = olInbox.Folders(strFolder)
On Error GoTo 0

If Not FolderToCheck Is Nothing Then
CheckForFolder = True
End If

ExitProc:
Set FolderToCheck = Nothing
Set olInbox = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Function

Function CreateSubFolder(strFolder As String) As Outlook.MAPIFolder
' assumes folder doesn't exist, so only call if calling sub knows that
' the folder doesn't exist; returns a folder object to calling sub
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder

Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olInbox = olNS.GetDefaultFolder(olFolderInbox).Folders("Follow-up")

Set CreateSubFolder = olInbox.Folders.Add(strFolder)

ExitProc:
Set olInbox = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Function

Continue reading...