Rename all subfolders of Outlook 2010 folder with the same text string

[Ironbars]

Hello,

I was trying to workout how to modify the solution from Charlize in another post titled "Solved: rename multiple subfolders in outlook inbox" (that I am unable to link due to low post counts).

Unfortunately I do not have the experience to work this out as quickly as I need.

What I would like help with is an Outlook VBA macro to select a folder and then rename all subfolders by prefixing them with the same string.

For example I want to prefix all subfolders of "Old email" with "Archive".
Inbox

Archive

Egg

Chicken
Ostrich
Diplodocus

Sausage
Beans
Spam

Would become

Inbox

Old email

Archive Egg

Archive Chicken
Archive Ostrich
Archive Diplodocus

Archive Sausage
Archive Beans
Archive Spam

Could anyone help me please?

Thank you

[skatonni]

The title is similar but your question is different.

The solution in http://www.vbaexpress.com/forum/show...+outlook+inbox may not be easily modifiable for your purposes.

Option Explicit

Private Sub SingleTierFolders_Rename()

    
    Dim oFolder As Folder
    Dim myfolder As Folder
    
    Set oFolder = ActiveExplorer.CurrentFolder

    For Each myfolder In oFolder.Folders
        
        Debug.Print vbCr & "Folder.Name: " & myfolder.name
        
        If Left(myfolder.name, 8) = "Archive " Then
            ' If the line is commented then can run multiple times
            '  with no double prefixing.
            ' If the line is uncommented will revert to original folder names
               myfolder.name = Right(myfolder.name, Len(myfolder.name) - 8)
                
        Else
            myfolder.name = "Archive " & myfolder.name
                
        End If
        
    Next
    
ExitRoutine:
    Set oFolder = Nothing
    
End Sub

If there are sub-subfolders then a more complex solution.

Option Explicit

Dim oFolderName As String

Private Sub MultiTierFolders_Rename()
    Dim oFolder As Folder
    Set oFolder = ActiveExplorer.CurrentFolder
    oFolderName = oFolder.name
    LoopFolders oFolder.Folders, True
    
ExitRoutine:
    Set oFolder = Nothing
        
End Sub

Private Sub LoopFolders(Folders As Folders, ByVal Recursive As Boolean)
    ' http://www.vboffice.net/sample.html?...2&cmd=showitem
    Dim myfolder As Folder
    
    For Each myfolder In Folders
        
        Debug.Print vbCr & "Folder.Name: " & myfolder.name
        
        ' Act on subfolders not the selected folder
        If myfolder.name <> oFolderName Then
        
            If Left(myfolder.name, 8) = "Archive " Then
                ' If the line is commented then can run multiple times
                '  with no double prefixing.
                ' If the line is uncommented will revert to original folder names.
                myfolder.name = Right(myfolder.name, Len(myfolder.name) - 8)
                
            Else
                myfolder.name = "Archive " & myfolder.name
                
            End If
            
        End If
            
        If Recursive Then
            LoopFolders myfolder.Folders, Recursive
        End If
        
    Next
    
End Sub

[Ironbars]

That works for me.
Thank you Skatonni.