Outlook VBA - renaming outlook folders using find/replace code that references excel workbook/sheet: it converted all folder text to lowercase

[dougmarkham]

Hi Folks,


Basic issue:

I have a requirement to rename many outlook folders/sub-folders and I thought I'd found the perfect outlook VBA code; however, I have two issues with it 1) it's changing the case of my outlook folders to lowercase 2) It's doing part matches.


Detail

The code below utilizes a 'find column and replace column' from an excel worksheet to stipulate the find / replace text, and searches the outlook folders looking for find text to replace.
However, there are two problems with the code which are beyond my outlook VBA experience:

Problem 1) The Function below converted the text in 'all' my folders into lowercase i.e., regardless of whether they were in the find / replace excel columns or not (see LCase).

Problem 2) If the find and replace text are similar, it doesn't search the whole 'find' folder string: e.g., if the find text = Meeting and the replace text = Meeting1, it keeps recursively renaming such that Meeting becomes Meeting1-->Meeting11-->Meeting111......Meeting111111111111111111 etc., till I escape out.

The code:

Public strFind, strReplace As String

Private Sub FindReplaceWordsinFolderNames()

    Dim objFolders As Outlook.Folders
    Dim objFolder As Outlook.Folder
    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 = "C:\Users\RenameOutlookFolders.xlsm"
    If strFilepath = False Then
        xlApp.Quit
        Set xlApp = Nothing
        Exit Sub
    End If
     
    Set xlWkb = xlApp.Workbooks.Open(strFilepath, ReadOnly:=True, Password:="mypassword123")
    Set xlSht = xlWkb.Worksheets("OutlookFolders")
   
    Dim iRow As Integer
    
    iRow = 2


    Set objFolders = Outlook.Application.Session.Folders("Douglas.Markham@thecompany.com").Folders
 
    'You need to input the specific words for find and replace
    While xlSht.Cells(iRow, 1) <> ""
    strFind = xlSht.Cells(iRow, 4)
    strReplace = xlSht.Cells(iRow, 5)
 
    For Each objFolder In objFolders
        Call ProcessFolders(objFolder)
        iRow = iRow + 1
    Next
 
    MsgBox "Complete!", vbExclamation, "Rename Folders"
End Sub
 
Private Sub ProcessFolders(ByVal objCurrentFolder As Outlook.Folder)
    Dim objSubfolder As Outlook.Folder
 
    On Error Resume Next
    If InStr(LCase(objCurrentFolder.Name), LCase(strFind)) > 0 Then

       'Find and replace the specific words
       objCurrentFolder.Name = Replace(LCase(objCurrentFolder.Name), LCase(strFind), strReplace)
    End If
 
    'Process all folders recursively
    If objCurrentFolder.Folders.Count > 0 Then
       For Each objSubfolder In objCurrentFolder.Folders
           Call ProcessFolders(objSubfolder)
       Next
    End If
End Sub

Would anyone please be willing to help me modify this code so that
a) it doesn't modify the case during the rename operation and
b) it doesn't search for the find-text in part of a folder-string but only looks at the whole folder-string during the find operation?

Kind regards,

Doug.

 

[Legacy 456155]

I don't see where, in your code, that anything is being forced to lowercase unless the string in
xlSht.Cells(iRow, 5) is already lower case.


If you want a case insensitive match for the entire string, replace InStr with a comparison such as:
If LCase(objCurrentFolder.Name) = LCase(strFind) Then

 

[dougmarkham]

I don't see where, in your code, that anything is being forced to lowercase unless the string in
xlSht.Cells(iRow, 5) is already lower case.


If you want a case insensitive match for the entire string, replace InStr with a comparison such as:
If LCase(objCurrentFolder.Name) = LCase(strFind) Then

Hi Dataluver,

Apologies for the delay in answering your reply, I've been off with the lurgy.
Thanks very much for your help, you've solved the issue and helped me learn a bit more about Outlook VBA---much appreciated!

It turns out that another person using similar code had the same issue as I:
I.e., that the VBA turned all their Outlook folders lower-case! The original code (see link at the end of this message) used input boxes to enter the find and replace text. Due to lack of error checking code, when the user presses cancel on the input box, the VBA will act like "" is the strFind, so it then turns all folder names into all lower case. I must have caused a similar issue when testing the code. The link below suggests adding the below If statement after the code for the find & replace inputboxes to solve the issue:

    If strFind = "" Or strReplace = "" Then
        Exit Sub
    End If

For completion, this is the full code I got to work: it cleared 800 lines in about 5 minutes and saved me many hours work.

Public strFind, strReplace As String

Sub FindReplaceWordsinFolderNames()

    Dim objFolders As Outlook.Folders
    Dim objFolder As Outlook.Folder
    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 = "C:\Users\RenameOutlookFolders.xlsm"

    If strFilepath = False Then
        xlApp.Quit
        Set xlApp = Nothing
        Exit Sub
    End If
     
    Set xlWkb = xlApp.Workbooks.Open(strFilepath, ReadOnly:=True, Password:="mypassword123")
    Set xlSht = xlWkb.Worksheets("OutlookFolders")
   
    Dim iRow As Integer
    
    iRow = 2


    Set objFolders = Outlook.Application.Session.Folders("Douglas.Markham@thecompany.com").Folders
 
    'You need to input the specific words for find and replace
    
    While xlSht.Cells(iRow, 4) <> "" 'Condition is that there is data in iRow for column 4 (find text)
        strFind = xlSht.Cells(iRow, 4) 'Find data in column 4
        strReplace = xlSht.Cells(iRow, 5) 'Replace data in column 5
    For Each objFolder In objFolders
        Call ProcessFolders(objFolder)
    Next
    iRow = iRow + 1
    Wend
    
    xlWkb.Close SaveChanges:=False
    xlApp.Quit
    Set xlWkb = Nothing
    Set xlApp = Nothing
    Set objParentFolder = Nothing

    
    MsgBox "Complete!", vbExclamation, "Rename Folders"
End Sub
 
Private Sub ProcessFolders(ByVal objCurrentFolder As Outlook.Folder)
    Dim objSubfolder As Outlook.Folder
 
    On Error Resume Next
    If LCase(objCurrentFolder.Name) = LCase(strFind) Then

       'Find and replace the specific words
       objCurrentFolder.Name = Replace(LCase(objCurrentFolder.Name), LCase(strFind), strReplace)
    End If
 
    'Process all folders recursively
    If objCurrentFolder.Folders.Count > 0 Then
       For Each objSubfolder In objCurrentFolder.Folders
           Call ProcessFolders(objSubfolder)
       Next
    End If
End Sub

Thanks very much for your time!

Kind regards,

Doug.

References for this code:
The code was composed by adaption of the following code...

How to Batch Find & Replace Specific Words in All Outlook Folder Names - Data Recovery Blog