Generate Outlook folders/subfolders under Inbox based on pattern in Excel columns-CodePudding

I found code online https://www.slipstick.com/macros/Create subfolders at multiple levels.txt to batch create folders and subfolders within Outlook and ran it and it all works okay.

I want to convert it to work in shared mailboxes.

Option Explicit

Public Sub MoveSelectedMessages()
    Dim objParentFolder As Outlook.Folder ' parent
    Dim newFolderName 'As String
    Dim strFilepath
    
    Dim xlApp As Object 'Excel.Application
    Dim xlWkb As Object ' As Workbook
    Dim xlSht As Object ' As Worksheet
    Dim rng As Object 'Range

    Set xlApp = CreateObject("Excel.Application")
    
    strFilepath = xlApp.GetOpenFilename
    If strFilepath = False Then
        xlApp.Quit
        Set xlApp = Nothing
        Exit Sub
    End If
      
    Set xlWkb = xlApp.Workbooks.Open(strFilepath)
    Set xlSht = xlWkb.Worksheets(1)
    Dim iRow As Integer
     
    iRow = 2
    
'select starting parent
Dim parentname
Dim Ns As Outlook.NameSpace
Dim Folder As Outlook.MAPIFolder
Dim olShareName As Outlook.Recipient
Dim olApp As Outlook.Application

Set objParentFolder = Application.ActiveExplorer.CurrentFolder

Set olApp = Nothing
Set Ns = Nothing
Set olShareName = Nothing

Set olApp = New Outlook.Application
Set Ns = olApp.GetNamespace("MAPI")
Set olShareName = Ns.CreateRecipient("[email protected]") '/// Owner's email address

Set Folder = Ns.GetSharedDefaultFolder(olShareName, olFolderInbox)

While xlSht.Cells(iRow, 1) <> ""
parentname = xlSht.Cells(iRow, 1)
newFolderName = xlSht.Cells(iRow, 2)
            
            
 If parentname = "Inbox" Then
 Set objParentFolder = Folder
    Else
 Set objParentFolder = Folder.Folders(parentname)
 End If
On Error Resume Next

Dim objNewFolder As Outlook.Folder
Set objNewFolder = objParentFolder.Folders(newFolderName)

If objNewFolder Is Nothing Then
    Set objNewFolder = objParentFolder.Folders.Add(newFolderName)
End If
    
    iRow = iRow   1

 ' make new folder the parent
 ' Set objParentFolder = objNewFolder
    
  Set objNewFolder = Nothing
Wend
     
    xlWkb.Close
    xlApp.Quit
    Set xlWkb = Nothing
    Set xlApp = Nothing
    Set objParentFolder = Nothing
End Sub

It asks you to select a formatted Excel doc and then creates the folders/subfolders based on the Excel file.

It doesn't create nested folders it just creates them all within the root inbox folder. It could be the Set Folder = Ns.GetSharedDefaultFolder(olShareName, olFolderInbox) reverts everything back to the root inbox rather than nesting them as it did in the user mailbox.

Parent Folder	Folder Name
Inbox	SubFolder
SubFolder	SubFolder01
SubFolder01	SubFolder01a
SubFolder01a	SubFolder01aA
SubFolder01a	SubFolder01aB
SubFolder01a	SubFolder01aC
SubFolder01a	SubFolder01aD
SubFolder01a	SubFolder01aE

CodePudding user response：

It seems you just need to change the following part from the code:

 If parentName = "Inbox" Then
 Set objParentFolder = Folder 
    Else
 Set objParentFolder = Folder.Folders(parentName)
 End If

To check whether a folder exists correctly you can use the Folders property. But if the folder doesn't exists an exception/error will be thrown. To handle such case you can use the following construction in the code:

Dim objNewFolder As Outlook.Folder

On Error Resume Next
Set objNewFolder = objParentFolder.Folders(newFolderName)

If objNewFolder Is Nothing Then
    Set objNewFolder = objParentFolder.Folders.Add(newFolderName)
End If

CodePudding user response：

I could not reproduce the results promised here
https://www.slipstick.com/developer/code-samples/create-outlook-folders-list-folder-names/
https://www.slipstick.com/macros/Create subfolders at multiple levels.txt

This generates nested folders for the example in the question.
Additionally, a subsequent entry of "Inbox" signals the start of a new set of nested folders.

Option Explicit

Private Sub GenerateFoldersFromExcelColumns()

    Dim objParentFolder As Folder
    Dim parentName As String
    
    Dim objInboxFolder As Folder
    
    Dim objNewFolder As Folder
    Dim newFolderName As String
    
    Dim xlApp As Object ' Excel.Application
    Dim xlWkb As Object ' Excel.Workbook
    Dim xlSht As Object ' Excel.Worksheet
    
    Dim filePath As Variant
    
    Dim iRow As Long
    
    Set xlApp = CreateObject("Excel.Application")
    
    filePath = xlApp.GetOpenFilename
    If filePath = False Then
        xlApp.Quit
        Set xlApp = Nothing
        Exit Sub
    End If
      
    Set xlWkb = xlApp.Workbooks.Open(filePath)
    Set xlSht = xlWkb.Worksheets(1)
    
    iRow = 2
    
    'select starting parent
    Set objInboxFolder = Session.GetDefaultFolder(olFolderInbox)
    
    ' Dim olShareName As Recipient
    'Shared email address
    ' Set olShareName = Session.CreateRecipient("[email protected]") 
    ' Debug.Print "olShareName: " & olShareName
    ' Set objInboxFolder = Session.GetSharedDefaultFolder(olShareName, olFolderInbox)
    
    While xlSht.Cells(iRow, 1) <> ""
        
        parentName = xlSht.Cells(iRow, 1)
        Debug.Print "parentname: " & parentName
        
        newFolderName = xlSht.Cells(iRow, 2)
        Debug.Print "newFolderName: " & newFolderName
        
        If parentName = "Inbox" Then
        
            Set objParentFolder = objInboxFolder
            
            Debug.Print "parentname: " & parentName
            Debug.Print "objParentFolder.name: " & objParentFolder.name
            Debug.Print "newFolderName: " & newFolderName
            
            ' Alternative code to avoid On Error Resume Next
            ' Check if an Outlook folder exists; if not create it
            '  https://stackoverflow.com/questions/53365384
            
            On Error Resume Next
            ' Try to create the folder without verification
            ' Bypass error when folder exists
            Set objNewFolder = objParentFolder.Folders.Add(newFolderName)
            On Error GoTo 0 ' As soon as possible after On Error Resume Next
            
            Set objNewFolder = objParentFolder.Folders(newFolderName)
            Debug.Print "objNewFolder.name: " & objNewFolder.name
            
            ' for debugging
            'Set ActiveExplorer.CurrentFolder = objNewFolder
            
        ElseIf parentName = objParentFolder.name Then
        
            Debug.Print "parentname: " & parentName
            Debug.Print "objParentFolder.name: " & objParentFolder.name
            Debug.Print "newFolderName: " & newFolderName
            
            On Error Resume Next
            Set objNewFolder = objParentFolder.Folders.Add(newFolderName)
            On Error GoTo 0 ' As soon as possible after On Error Resume Next
            
            Set objNewFolder = objParentFolder.Folders(newFolderName)
            Debug.Print "objNewFolder.name: " & objNewFolder.name
            
            ' for debugging
            'Set ActiveExplorer.CurrentFolder = objNewFolder
            
        Else
            
            Set objParentFolder = objParentFolder.Parent
            
            Debug.Print "parentname: " & parentName
            Debug.Print "objParentFolder.name: " & objParentFolder.name
            Debug.Print "newFolderName: " & newFolderName
            
            On Error Resume Next
            Set objNewFolder = objParentFolder.Folders.Add(newFolderName)
            On Error GoTo 0 ' As soon as possible after On Error Resume Next
            
            Set objNewFolder = objParentFolder.Folders(newFolderName)
            Debug.Print "objNewFolder.name: " & objNewFolder.name
            
            ' for debugging
            'Set ActiveExplorer.CurrentFolder = objNewFolder
            
        End If
        
        iRow = iRow   1
        
        ' make new folder the parent
        Set objParentFolder = objNewFolder
        Debug.Print "objParentFolder.name: " & objParentFolder.name
        
        ' No purpose in this case
        '  but is typical with On Error Resume Next logic
        '  when there is a test for Nothing
        'Set objNewFolder = Nothing
                    
    Wend

exitRoutine:

    xlWkb.Close
    xlApp.Quit
    
    Set xlSht = Nothing
    Set xlWkb = Nothing
    Set xlApp = Nothing
        
    Debug.Print "Done."
    
End Sub