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

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

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.

Code:

---

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.

Code:

---

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

---

That works for me.
Thank you Skatonni.