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/showthread.php?24999-Solved-rename-multiple-subfolders-in-outlook-inbox&highlight=rename+multiple+subfolders+in+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?lang=en&mnu=2&smp=12&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.