Outlook Macro - Creating folders [Solved/Closed]

Picazo - Nov 21, 2008 at 09:58 AM - Latest reply:  tom
- Aug 26, 2011 at 04:35 PM
Hello,

Could anyone guide me in creating an outlook macro that does the following:

I receive emails very frequently that have a "word" in the title of the email in the format of issue-xxxx, where xxxx is a 4 digit number. I have created a mailbox folder called issues. What I would like the macro to do is to find all emails with a string of the format issue-xxxx in the title and look for a folder under issues with that same name. If one is not found, then it should be created. The email should then be moved to that subfolder.

For example, suppose an email comes in with the word issue-1234. The macro, when run (hopefully via the toolbar), should find that email and check for a folder called issue-1234 under the issues folder and create it if it was not found. The email should then be moved to that issue-1234 folder.

I have not really done any macro programming in the past, so any help on how to get started would be appreciated. If you happen to have a macro that does this already, and want to share the code, that would be even better.

Thanks,
Picazo
See more 

16 replies

Best answer
5
Thank you
This is a rough start... still need to verify if folder already exists.

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

' Run this code to start your rule.
Sub StartRule()
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("Testing")
End Sub

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

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

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

Set colMatches = objRegEx.Execute(Item.Subject)
If colMatches.Count > 0 Then
For Each myMatch In colMatches
' Set objProjectFolder = objDestinationFolder.Folders(myMatch.Value)
' If TypeName(objProjectFolder) = "Nothing" Then
Set objProjectFolder = objDestinationFolder.Folders.Add(myMatch.Value)
' End If
Item.Move objProjectFolder
Next
End If

Set objProjectFolder = Nothing
End Sub


To have the macro run every time Outlook starts, change the name of the subroutine from StartRule to Application_Startup or call the StartRule procedure that is in the Application_Startup procedure. The Application_Startup procedure must be located in the ThisOutlookSession module.

Thank you, Pepper 5

Something to say? Add comment

CCM has helped 1663 users this month

1
Thank you
I changed my exists check to
If objProjectFolder Is Nothing Then

Now I need to pretty it up a bit. This should get you started in the right direction
hi, I am interested with this.
have u done it?
can you enlighten me a little bit please? :)
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
bernhard > Pepper - Jan 20, 2010 at 09:42 AM
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
Pepper > bernhard - Mar 9, 2010 at 12:52 PM
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.
Pepper > bernhard - Mar 9, 2010 at 01:41 PM
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
0
Thank you
I too am interested a similar function. I will keep you informed if I get something close.
Lacyjee 6 Posts Friday July 3, 2009Registration date February 12, 2010 Last seen - Feb 12, 2010 at 05:59 AM
0
Thank you
Pst files are better saved in the Outlook 2007. This works effectively in receiving and sending mails and other important messages. For Vista operating system the PST Repair Vista tool works better. This can even perform a well recoveryof the lost, damaged and corrupted messages easily. To know about the features and work procedureof PST Repair Vista Software have a look on, http://www.pstrepairvista.com
0
Thank you
i didn't get it? how to run
But it will only run that sub and I think you called it Sub StartRule() - is there a call to the private sub
Here is the latest...
' 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 (created 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 contain either an M or Z 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)

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
Hi,

First of all clarify that I don't have any idea about Macros in outlook.
But I am trying to do exactly the same as Picazo, I have seen the post and I have tried to make it work, but it gives me compilation error on the first line.
I create a macro and paste the code, I am probably not doing it right. Can anyone let me know how to make it work?

Thanks !

Marc
Hello All

I am actually looking for something link this
that works a bit diffrently is looks at the from "Display name" "Email Address"
Such as Mark Doe ,MDOE@doe.com"
and then sees is there is a folder under the inbox,doe.com,Mark Doe,
If so moves the mail into it, if not creates the folder structure and moves the mail.

Can anyone assist?
Hi

You can use Inlook Time Management. it gives you the exact archiving functionality you look for.

www.inlooktm.com