Outlook Macro - Creating folders [Solved/Closed]

It is not elegant but is good enough for my personal use. Let me know if you make enhancements that I might find useful. Thanks.

' File projects in their own subfolders
' Written by Bryce Pepper (bpepper@kcsouthern.com)
' Searches subject for a M or Z project number (must be between 4-6 digits)
' and files them in a project subfolder (create folder if one does not exist)
' added support for P & R projects 2009-03-03 B.Pepper
' added support for # to make Bill Z. happy 2009-03-04 B.Pepper

Dim WithEvents objInboxItems As Outlook.Items
Dim objDestinationFolder As Outlook.MAPIFolder

Sub Application_Startup()
Dim objNameSpace As Outlook.NameSpace
Dim objInboxFolder As Outlook.MAPIFolder

Set objNameSpace = Application.Session
Set objInboxFolder = objNameSpace.GetDefaultFolder(olFolderInbox)
Set objInboxItems = objInboxFolder.Items
Set objDestinationFolder = objInboxFolder.Parent.Folders("Projects")
End Sub

' Run this code to stop your rule.
Sub StopRule()
Set objInboxItems = Nothing
End Sub

' This code is the actual rule.
Private Sub objInboxItems_ItemAdd(ByVal Item As Object)
Dim objProjectFolder As Outlook.MAPIFolder
Dim folderName As String

Set objRegEx = CreateObject("VBScript.RegExp")
objRegEx.Global = False
' Search for email subjects that contains project number (M007439, Z6312)
objRegEx.Pattern = "([M,Z,P,R,#]\d{4,6})"

Set colMatches = objRegEx.Execute(Item.Subject)
If colMatches.Count > 0 Then
For Each myMatch In colMatches
If Left$(myMatch.Value, 1) = "#" Then
folderName = "M" & Right$("00" & Mid$(myMatch.Value, 2), 6)
Else
folderName = Left$(myMatch.Value, 1) & Right$("00" & Mid$(myMatch.Value, 2), 6)
End If

If FolderExists(objDestinationFolder, folderName) Then
Set objProjectFolder = objDestinationFolder.Folders(folderName)
Else
Set objProjectFolder = objDestinationFolder.Folders.Add(folderName)
End If
Item.Move objProjectFolder
Next
End If

Set objProjectFolder = Nothing
End Sub

Function FolderExists(parentFolder As MAPIFolder, folderName As String)
Dim tmpInbox As MAPIFolder

On Error GoTo handleError
' If the folder doesn't exist, there will be an error in the next
' line. That error will cause the error handler to go to :handleError
' and skip the True return value

Set tmpInbox = parentFolder.Folders(folderName)
FolderExists = True
Exit Function
handleError:
FolderExists = False
End Function

Hi Pepper,

thanks for your wonderful script! It helped very much in finding my first steps for my own implementation.

To further improve your script I changed some small things and I want to add a new "feature" to it, and with common forces I think we can make it even better.
What I am trying to do is the following:
I have a big archive structure, where the different topics have an unique id. This unique id is also the name of the folder, BUT the folder can also have a description, e.g. "0000_this folder holds this content"

is there a way to have a wildcard appended to the foldername the msg will be moved?

thanks for your help
bernhard

I suppose you could modify the FolderExists routine to enumerate thru all the folders and use the regexp to find a partial match -- return true if found / false not found. Let me know how you come along with this.

Try this...

Function FolderExists(parentFolder As MAPIFolder, folderName As String)

Set objRegEx = CreateObject("VBScript.RegExp")
objRegEx.Global = False
objRegEx.Pattern = "(" & folderName & ".*)"

For Each F In parentFolder.Folders
Set colMatches = objRegEx.Execute(F.Name)
If colMatches.Count > 0 Then
FolderExists = True
folderName = colMatches(0).Value
Exit Function
End If
Next

FolderExists = False
End Function