Look for and create folders programmatically in Outlook

If you are writing VBA code for Outlook, you might have a need to check for an existing folder, and create it if it doesn't exist.

Here are two functions that can assist. I wrote one that checks for an existing folder, and returns TRUE if it exists. It assumes a specific folder hierarchy, so you'll need to adjust it if the folders you are working with are on a different level. Works in Outlook but can be adapted for Excel use as well.

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)

' 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

To use this in your code:

If CheckForFolder("My Folder") Then
  ' your code here
End If

This code will look for Inbox\My Folder and return TRUE if it exists.

The second function will actually create the sub folder. It is written so that it should only be called if the folder doesn't exist, so it should be used in tandem with the above 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)

Set CreateSubFolder = olInbox.Folders.Add(strFolder)

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

This function returns an object reference to the MAPIFolder Object created by the code. Usage would be:

Dim MyFolder As Outlook.MAPIFolder
If CheckForFolder("My Folder") = False Then ' Folder doesn't exist
  Set MyFolder = CreateSubFolder("My Folder")
End If

Filed Under: Outlook, VBA

Tagged With: add, folders

Function CreateSubFolder(strFolder As String, blnForSent as Boolean) 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 ' Have calling sub set blnForSent = True for folder to display 'To' and 'Sent' fields ' blnForSent = False for folder to display 'From' and 'Received' fields Dim olApp As Outlook.Application Dim olNS As Outlook.Namespace Dim olInbox As Outlook.MAPIFolder Dim olFldr As Outlook.MAPIFolder Set olApp = Outlook.Application Set olNS = olApp.GetNamespace("MAPI") Set olInbox = olNS.GetDefaultFolder(olFolderInbox) Set olFldr = olInbox.Folders.Add(strFolder) If blnForSent Then 'olFldr.CurrentView.??? End If Set CreateSubFolder = olFldr ExitProc: Set olFldr = Nothing Set olInbox = Nothing Set olNS = Nothing Set olApp = Nothing End Function

14 Comments on Look for and create folders programmatically in Outlook:

Reid Parker writes:
February 8, 2009 at 7:36 pm
That was EXACTLY the piece of code I was looking for. Thanks very much for posting it!
JP writes:
February 9, 2009 at 12:00 pm
Glad to help, Reid.
Gary writes:
May 5, 2009 at 11:56 am
That's fine if you're going to use it to keep mail items that you recieve. What if you use it to keep mail items you've sent? When you click on the folder, it has 'From' and 'Recieved' fields. How do you modify the folder after adding it so 'To' and 'Sent' fields are shown instead?
- JP writes:
  May 5, 2009 at 6:38 pm
  Gary,
  Right-click on one of the fields and select "Field Chooser", you can add those fields back in.

Gary writes:

May 6, 2009 at 10:15 am

Correct, but is there a way to do that in VBA?
I would guess something like

diya writes:
July 22, 2010 at 5:01 pm
hey hi i am very new, wanted to add contacts in my new folder but unable to do so,
please help me !
- JP writes:
  July 22, 2010 at 6:16 pm
  The code I posted will only create Mail-type folders. You would need to change this line:
```
Set olInbox = olNS.GetDefaultFolder(olFolderContacts)
```
  Then in my sample code, "MyFolder" would point to your new Contacts folder:
```
Set MyFolder = CreateSubFolder("My Folder")
```
  All you would do then is use the Folder.Items.Add method to add a new contact to the new folder:
```
MyFolder.Items.Add
```

JP writes:
May 6, 2009 at 11:03 pm
I'm still trying to nail down the exact syntax, but it would be something like
```
Dim vw As View
Set vw = CreateSubFolder.Views.Add("My New View", olTableView, olViewSaveOptionAllFoldersOfType)
```
Actually setting the folder to that view seems to be a moving target.
DW writes:
July 22, 2011 at 12:14 pm
Hi,
great code but I'm trying to work out how to create the new folder in a a sub folder of Inbox.
i.e create a folder call JohnSmith in a 'clients' folder in the Inbox folder.
Any help would be very much appreciated.
Thanks
DW
- JP writes:
  July 22, 2011 at 7:06 pm
  Edit the code like this:
```
Set CreateSubFolder = olInbox.Folders("clients").Folders.Add(strFolder)
```
  And of course you would call the function like this:
```
CreateSubFolder("JohnSmith")
```
  - DW writes:
    July 23, 2011 at 4:50 am
    Fantastic, works brilliantly, just what I was looking for.
    Many thanks,
    DW
Dave Frank writes:
December 14, 2011 at 10:40 am
Hi JP
Thanks for your blog
I am trying to learn VB, and have a specific requirement.
I googled "How to make a series of directories in outlook inbox using VB" and found this thread.
I wish I was better at VB to take what is here, but my skills are not there yet.
I am a rookie to VB I am actually a CAD/CAM programmer (CATIA)
if you need help making Jet Fighter parts, I can return the favor and assist you, Ha Ha Ha
Any way, My issue is I work in the same company for 13 years, and archiving outlook is a time consuming labor intensive problem
My It manager says make subfolder for all your contacts, and move all the emails there. When the time comes to archive to PST files, the folder go with it. But that is all the help I get. IT means fend for yourself.
Anyway, I wish to automate this
The best possible code would look at my inbox, and create subfolders for all inbox, and out box contacts.
Once a week I delete all the unwanted emails, and then run the script.
If I get a new email from BillGates@microsoft, a subforder under inbox is created called microsoft_BillGates, and the emails is moved.
perhaps a subfolder is created called microsoft, and then I just get folders under there named BillGates, and JohnSmith, and Billy bob, all from Microsoft.
Any help is much appreciated.
Best Regards
Dave
- JP writes:
  December 16, 2011 at 9:13 pm
  I think you should post this on MrExcel or VBAX, you need more help than I can provide in comments.
Dave Frank writes:
December 14, 2011 at 7:37 pm
Hi
I got the code from some smart guy in the catua forum
I wonder how to change this for the sent items
Dave
Sub Main()
'———————————-
' ACCESS OUTLOOK VIA COM INTERFACES
'———————————-
Dim appOutlook ' As Outlook.Application
Set appOutlook = CreateObject("Outlook.Application", vbNullString)
Dim nsMAPI ' As Namespace
Set nsMAPI = appOutlook.GetNamespace("MAPI")
'——————————-
' MANAGE E-MAILS IN INBOX FOLDER
'——————————-
' get INBOX folder
Dim fldInbox ' As Folder
Set fldInbox = nsMAPI.GetDefaultFolder(olFolderInbox)
' cycle through all items in INBOX folder
Dim miEmail ' As MailItem
For Each miEmail In fldInbox.Items
' get domain from e-mail address
Dim aAddress() As String
aAddress = Split(miEmail.SenderEmailAddress, "@")
If (UBound(aAddress) > 0) Then
'——————————–
' FIND FOLDER WITH NAME OF DOMAIN
'——————————–
Dim sDomain As String
sDomain = aAddress(1)
Dim fldDomainFolder ' As Folder
Set fldDomainFolder = Nothing
On Error Resume Next
Set fldDomainFolder = fldInbox.Folders.Item(sDomain)
If (Err.Number 0) Then
Err.Clear
' create folder
Set fldDomainFolder = fldInbox.Folders.Add(sDomain)
End If
'—————————————
' FIND SUBFOLDER WITH NAME OF THE SENDER
'—————————————
Dim sSender As String
sSender = aAddress(0)
Dim fldSenderFolder ' As Folder
Set fldSenderFolder = Nothing
On Error Resume Next
Set fldSenderFolder = fldDomainFolder.Folders.Item(sSender)
If (Err.Number 0) Then
Err.Clear
' create folder
Set fldSenderFolder = fldDomainFolder.Folders.Add(sSender)
End If
'——————————-
' MOVE E-MAIL TO SENDER'S FOLDER
'——————————-
If Not (fldSenderFolder Is Nothing) Then
On Error Resume Next
miEmail.Move fldSenderFolder
Err.Clear
End If
End If
Next
'——————————-
' MANAGE E-MAILS IN OUTBOX FOLDER
'——————————-
' get OUTBOX folder
Dim fldOutbox ' As Folder
Set fldOutbox = nsMAPI.GetDefaultFolder(olFolderOutbox)
' cycle through all items in INBOX folder
' Dim miEmail As MailItem
For Each miEmail In fldOutbox.Items
' get domain from e-mail address
'Dim aAddress() As String
aAddress = Split(miEmail.SenderEmailAddress, "@")
If (UBound(aAddress) > 0) Then
'——————————–
' FIND FOLDER WITH NAME OF DOMAIN
'——————————–
'Dim sDomain As String
sDomain = aAddress(1)
'Dim fldDomainFolder As Folder
Set fldDomainFolder = Nothing
On Error Resume Next
Set fldDomainFolder = fldOutbox.Folders.Item(sDomain)
If (Err.Number 0) Then
Err.Clear
' create folder
Set fldDomainFolder = fldOutbox.Folders.Add(sDomain)
End If
'—————————————
' FIND SUBFOLDER WITH NAME OF THE SENDER
'—————————————
'Dim sSender As String
sSender = aAddress(0)
'Dim fldSenderFolder As Folder
Set fldSenderFolder = Nothing
On Error Resume Next
Set fldSenderFolder = fldDomainFolder.Folders.Item(sSender)
If (Err.Number 0) Then
Err.Clear
' create folder
Set fldSenderFolder = fldDomainFolder.Folders.Add(sSender)
End If
'——————————-
' MOVE E-MAIL TO SENDER'S FOLDER
'——————————-
If Not (fldSenderFolder Is Nothing) Then
On Error Resume Next
miEmail.Move fldSenderFolder
Err.Clear
End If
End If
Next
End Sub