Recursive Creating a Folder Tree in Outlook

[Petille]

Hi,
I have been creating folders in Outlook using a simple macro that creates folders from the first column of an Excel sheet under the folder currently selected. That macro is based in Outlook.

We are at the beginning of a new fiscal year and I would really like to create the whole tree at once. It represents about 4000 folders.

I looked online for a recursive example specific for outlook but all I found was: https://social.technet.microsoft.co...re-using-recursive-function-in-excel-vba.aspx It is supposed to create hierachical folders but in the regular directory. My attempts at modifying it so that it works also for Outlook didn't work.

I have attached the drop box link to download my Excel sheet with all the 4k+folders in the first 3 columns
I pasted in the VBE module 1 the macro that I used in Outlook to create one subfolder at the time. (That is about 168 subfolders, by bunch of 25 copied in the first column, save, execute, replace and repeat....)

Thanks for giving me pointers as to how to do that.

https://www.dropbox.com/s/yn28pup2hhyc4ef/CreateFolders3.xlsm?dl=0

 

[Petille]

I forgot to say that the top parent folder is not a .pst but a Public Folder

 

[John_w]

Try this, based on your Sheet1 data, but you must first delete columns D:L so that the UsedRange data doesn't go beyond column C.

I'm not sure if the code which defines the top parent folder will work with a Public folder, but I have included the Outlook PickFolder method which may allow you to browse and select a Public folder (I don't know).

This code uses named Outlook objects (early binding), so you must set a reference to Microsoft Outlook Object Library n.0 via Tools -> References in the VBA editor.

Option Explicit

'Reference for early binding: Microsoft Outlook n.0 Object Library

Public Sub Create_Outlook_Folder_Tree()

    Dim outlookOpened As Boolean
    Dim outApp As Outlook.Application
    Dim outNs As Outlook.Namespace
    Dim outTopParentFolder As Outlook.Folder
    Dim foldersArray As Variant
    
    foldersArray = ThisWorkbook.Worksheets("Sheet1").UsedRange.Value
    
    If Not IsOutlookRunning Then
        outlookOpened = True
        CreateObject("WScript.Shell").Run "outlook.exe", 3, False
        Set outApp = CreateObject("Outlook.Application")
    Else
        outlookOpened = False
        Set outApp = GetObject(, "Outlook.Application")
    End If

    Set outApp = New Outlook.Application  'CreateObject("Outlook.Application")
    Set outNs = outApp.GetNamespace("MAPI")
    
    'Define top parent folder or allow user to choose it
    
    'Set outTopParentFolder = outNs.GetDefaultFolder(olFolderInbox).parent.folders("A top folder within Outlook account").folders("Subfolder")
    Set outTopParentFolder = outNs.PickFolder
    
    If Not outTopParentFolder Is Nothing Then
        'Create folders starting at row 2, column 1 of foldersArray
        Create_Outlook_Folders outTopParentFolder, foldersArray, 2, 1
    End If
    
    'Close Outlook if not previously open
    
    If outlookOpened Then outApp.Quit
    
End Sub


Private Function Create_Outlook_Folders(outParentFolder As Outlook.Folder, foldersArray As Variant, r As Long, c As Long) As Long

    Dim n As Long
    Dim sibling As Boolean, child As Boolean
    Dim outFolder As Outlook.Folder
    
    sibling = False
    child = False
    
    'Child if: (r, c+1) <> ""
    'Sibling if: Not child and (r+1, c) <> ""
    
    n = 0
    
    Do
        If foldersArray(r + n, c) <> "" Then
            Debug.Print r + n, outParentFolder.Name & "\" & foldersArray(r + n, c)
            
            'Create folder if it doesn't exist
            
            On Error Resume Next
            Set outFolder = outParentFolder.folders(foldersArray(r + n, c))
            On Error GoTo 0
            If outFolder Is Nothing Then outParentFolder.folders.Add foldersArray(r + n, c)
        End If
        
        'If cell to right is populated then it is a child folder
        
        child = False
        If c < UBound(foldersArray, 2) Then
            If foldersArray(r + n, c) <> "" And foldersArray(r + n, c + 1) <> "" Then child = True
        End If
        
        'If cell below is populated then it is a sibling folder
        
        sibling = False
        If Not child Then
            If r + n + 1 <= UBound(foldersArray, 1) Then
                If c = 1 Then
                    If foldersArray(r + n + 1, c) <> "" Then sibling = True
                Else
                    If foldersArray(r + n + 1, c - 1) = "" And foldersArray(r + n + 1, c) <> "" Then sibling = True
                End If
            End If
        End If
        
        If child Then
            'Recursive call to create child folder
            n = n + 1 + Create_Outlook_Folders(outParentFolder.folders(foldersArray(r + n, c)), foldersArray, r + n, c + 1)
        End If
            
        'Increment count of sibling folders in this parent folder
        
        If sibling Then n = n + 1
        DoEvents
        
    Loop While (sibling Or child) And (r + n <= UBound(foldersArray, 1))
    
    If n > 0 Then n = n - 1
    Create_Outlook_Folders = n
    
End Function


Private Function IsOutlookRunning() As Boolean
    Dim Outlook As Object
    Set Outlook = Nothing
    On Error Resume Next
    Set Outlook = GetObject(, "Outlook.Application")
    On Error GoTo 0
    IsOutlookRunning = Not Outlook Is Nothing
End Function

The hardest part was writing the recursive algorithm to traverse the cells containing the folder names - quite messy compared to the very clean algorithm to traverse a Windows directory tree. I'm sure someone else could write a better algorithm.

 

[Petille]

Thank you! I will try this and let you know how it went!

 

[Petille]

Wow, you are a genius! This worked beautifully! I first tested it by creating a folder in my user local account, Sample Folders, same level as Inbox. I selected that folder to create the tree to move it to the public Folders but we are on 365 and there was too much sync going on so I decided to just go for it and use it on a folder in the public tree. It is creating the folders as we speak. It is a bit slow compare to how it performed on the local account, but it is going smoothly. Thank you so much.

I'm sorry I did not get back before. We were swamped at the office and I wanted to take the time to do it when I would not be under pressure so that I could address any issue that could happen. So I just did it now. Thank you again! It is when solutions like this happen that I get motivated to learn more vba techniques!