Loop through all subfolders - excel

I am trying to loop through all subfolders. This script works but then only pulls some folders and not others. I need it to pull all files in the folder. I did not create this full script but would like to modify it.
UPDATE:
I tried this alternate solution below and it works.
Sub loopAllSubFolderSelectStartDirectory()
Dim FSOLibrary As Object
Dim FSOFolder As Object
Dim folderName As String
'Set the folder name to a variable
folderName = "C:\Users\dreid_000\Desktop\PhaseII\"
'Set the reference to the FSO Library
Set FSOLibrary = CreateObject("Scripting.FileSystemObject")
'Another Macro must call LoopAllSubFolders Macro to start
LoopAllSubFolders FSOLibrary.GetFolder(folderName)
End Sub
Sub LoopAllSubFolders(FSOFolder As Object)
Dim FSOSubFolder As Object
Dim FSOFile As Object
Dim soldname As String
Dim sNewName As String
Dim sTempFile() As String
Dim sPath As String
Set Fso = CreateObject("Scripting.FileSystemObject")
'For each subfolder call the macro
For Each FSOSubFolder In FSOFolder.subfolders
LoopAllSubFolders FSOSubFolder
Next
'For each file, print the name
For Each FSOFile In FSOFolder.Files
'Insert the actions to be performed on each file
FSOFile.Name = "PhaseII.xlsx"
'This example will print the full file path to the immediate window
Debug.Print FSOFile.Path
Next
End Sub

Here is a good, generic solution that can meet basically any search folder and its subfolders requirements. It is a function that calls itself recursively and outputs a dictionary object containing the complete results, code commented for clarity:
Public Function SearchDirectory(ByVal arg_sFolderPath As String, _
Optional ByVal arg_sSearch As String = "*", _
Optional ByVal arg_bMatchCase As Boolean = False, _
Optional ByVal arg_bIncludeSubFolders As Boolean = True, _
Optional ByRef arg_hResults As Object) _
As Object
'Purpose of this function is to search a directory (and probably all of its subfolders)
'for files that match an optionally provided search string, and the match may or may
'not be case sensitive. It then collects all of the results in a dictionary object and
'returns that dictionary object as the function output
'
'Parameters:
' arg_sFolderPath: [Required][String] -The folder path of the original directory that will be searched
'
' arg_sSearch: [Optional][String] -A pattern that will be matched against.
' -For example, to find all Excel files you would use "*.xls*"
' -Default value is "*" which will return all files
'
' arg_bMatchCase: [Optional][Boolean] -Specifies whether or not to match arg_sSearch as case sensitive
' -For example, if this is set to True and the arg_sSearch is set to "*.xls*",
' then an Excel file named "EXCELFILE.XLSX" would NOT be found
' -Default value is False which will make matches not case sensitive
'
' arg_bIncludeSubFolders [Optional][Boolean] -Specifies whether or not to search all subfolders recursively
' -Default value is True which will include results in all subfolders
'
' arg_hResults [Optional][Dictionary Object] -An existing dictionary object to hold the results in
' -Typically this will not be provided on initial call, and is used
' during recursive calls to store all relevant results for output
'
'Author: tigeravatar on stackoverflow at https://stackoverflow.com/questions/56970854/loop-through-all-subfolders
'Created: July 10, 2019
'Static so that during recursive search it doesn't need to be recreated on every recursive call
Static oFSO As Object
If oFSO Is Nothing Then Set oFSO = CreateObject("Scripting.FileSystemObject")
'Check if arg_hResults was provided (typically not on first call, but will be on all subsequent recursive calls)
'This preserves all found matching file results throughout all recursive calls of the function
Dim hResults As Object
If arg_hResults Is Nothing Then Set hResults = CreateObject("Scripting.Dictionary") Else Set hResults = arg_hResults
'Variable used to store the folder path separator
Dim sPS As String
sPS = Application.PathSeparator
'Adjust so that even if folder path isn't passed with an ending Path Separator, the function can handle it appropriately
Dim sFolderPath As String
If Right(arg_sFolderPath, Len(sPS)) = sPS Then sFolderPath = arg_sFolderPath Else sFolderPath = arg_sFolderPath & sPS
'Verify the folder path provided is valid. Allow for hidden folders to be searched as well
If Len(Dir(sFolderPath, vbDirectory + vbHidden)) = 0 Then
MsgBox "Invalid directory path provided: " & Chr(10) & arg_sFolderPath, , "Search Directory Error"
Set SearchDirectory = Nothing
Exit Function
End If
'Using the FileSystemObject, work with the provided and validated folder path
Dim oFolder As Object
Set oFolder = oFSO.GetFolder(sFolderPath)
'Loop through all files in the folder
Dim oFile As Object
Dim bMatch As Boolean
For Each oFile In oFolder.Files
'Verify the file matches the provided search pattern (if any) according to case sensitivity
bMatch = False
If arg_bMatchCase = True Then
If oFile.Name Like arg_sSearch Then bMatch = True
Else
If LCase(oFile.Name) Like LCase(arg_sSearch) Then bMatch = True
End If
'If match found, add it to the hResults dictionary
If bMatch = True Then
If Not hResults.Exists(oFile.Path) Then hResults.Add oFile.Path, oFile.Path
End If
Next oFile
'If set to search subfolders (default behavior), have the function recursively call itself to search all subfolders
If arg_bIncludeSubFolders = True Then
Dim oSubFolder As Object
For Each oSubFolder In oFolder.SubFolders
Set hResults = SearchDirectory(oSubFolder.Path, arg_sSearch, arg_bMatchCase, arg_bIncludeSubFolders, hResults)
Next oSubFolder
End If
'Set function output to the hResults dictionary if it contains any matched file results
If hResults Is Nothing Then
Set SearchDirectory = Nothing
Else
If hResults.Count = 0 Then Set SearchDirectory = Nothing Else Set SearchDirectory = hResults
End If
End Function
This is an example of how to use the function and work with its results:
Sub tgr()
'Create an object variable and set it to the function SearchDirectory
'Provide SearchDirectory arguments as desired
Dim hFoundFiles As Object
Set hFoundFiles = SearchDirectory("C:\Test")
'Verify it actually found files matching your criteria in the folder specified
If hFoundFiles Is Nothing Then Exit Sub 'Didn't return any results
'Can output results to a worksheet
ActiveWorkbook.ActiveSheet.Range("A1").Resize(hFoundFiles.Count).Value = Application.Transpose(hFoundFiles.Keys)
'Can loop through each result if you need to do something with them individually
Dim vFile As Variant
For Each vFile In hFoundFiles.Keys
'Do something here
Debug.Print vFile
Next vFile
End Sub

Related

Extract a folder name from file path

I have a file path (which is a connection path for the worksheet) in the following format:
C:\ExcelFiles\Data\20140522\File1_20140522.csv
I want to extract 20140522.
I tried using responses of How to extract groups of numbers from a string in vba, but they don't seem to work in my case.
please find below
Filename = "C:\ExcelFiles\Data\20140522\File1_20140522.csv"
a = Replace(Mid(Filename, InStrRev(Filename, "_") + 1, Len(Filename)), ".csv", "")
Try the following. Folder is selected.
Sub Folder_S()
Dim sFolder As FileDialog
On Error Resume Next
Set sFolder = Application.FileDialog(msoFileDialogFolderPicker)
If sFolder.Show = -1 Then
Folder_Select sFolder.SelectedItems(1), True
End If
End Sub
Sub Folder_Select(ByVal SourceFolderName As String, ByVal IncludeSubfolders As Boolean)
Dim FSO As Object
Dim SourceFolder As Object
Dim FileItem As Object
Dim strFile As String
Dim FileName As Variant
Dim pathParts() As String
Dim pathPart As String
Dim i As Long
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.GetFolder(SourceFolderName)
pathParts = Split(SourceFolder.Path, Application.PathSeparator)
pathPart = SourceFolder.Path
For i = 0 To UBound(pathParts)
If pathParts(i) = "20140522" Then
pathPart = pathParts(i - 0)
Exit For
End If
Next i
Row = ActiveCell.Row
With CreateObject("Scripting.Dictionary")
For Each FileItem In SourceFolder.Files
strFile = FileItem.Name
.Item(strFile) = Array(FileItem.Name)
Next FileItem
If .Count > 0 Then
For Each FileName In .Items
Cells(Row, 2).Formula = pathPart
Next FileName
End If
End With
End Sub
I found your question by searching a solution how to get a folder path from a file that is inside this folder path. But your question doesn't match exactly what I need. For those who by your question title will find it for the same purpose as I found, below is my function:
Function getFolderPathFromFilePath(filePath As String) As String
Dim lastPathSeparatorPosition As Long
lastPathSeparatorPosition = InStrRev(filePath, Application.PathSeparator)
getFolderPathFromFilePath = Left(filePath, lastPathSeparatorPosition - 1)
End Function
In some solutions for this purpose, I used FSO, but it takes resources, and I think it isn't worthy to create FSO object if you need it only for this simple function.
the accepted answer is not accurate to read the folder name. here is more dynamic code.
use splitter which splits string based on delimeter and makes an array. now read the second last element in array, thats the folder name.
Dim fileName As String
fileName = "C:\ExcelFiles\Data\20140522\File1_20140522.csv"
Dim vPathSplitter As Variant
vPathSplitter = Split(fileName, "\")
MsgBox (vPathSplitter(UBound(vPathSplitter) - 1))
The below answer gets your file path from a range, rather than a fixed string. Much more handy if your planning on getting your filename from your sheets, which I imagine you are.
Sub GetFileDate()
Dim filename As String
filename = Sheets("Sheet1").Range("C9").Value 'Or Wherever your file path is
MsgBox Replace(Right(filename, 12), ".csv", "")
End Sub
This assumes the numbers your extracting will ALWAYS be dates in YYYYMMDD format and the file type is always .csv

Use Dir to find file without "AAA"

I have some files that are called Team-(Random Number).txt.
Dir("Team-" & "*" & ".txt")
But when there have been changes there could be text files called Team-(Random Number)-AAA.txt, Team-(Random Number)-AAB.txt and so but the most recent file is always called Team-(Random Number).txt.
Since Dir only returns 1 file and does this randomly is there a way to get the file Team-(Random Number).txt?
It should be no problem if dir returned the result in a normal order but apparently it does it randomly.
I've thought of excluding the -AAA part but don't know what the syntax should. Or in a less efficient way to get all files and sort it in an array but with 10 - 200 files it's not very efficient.
Now I'm hoping could give me the syntax of excluding the part or other workaround for my problem thanks!
I'd say go for Regular Expressions.
Private Sub TeamTxtExists()
Dim Path As String, Pattern As String, FileFound As String
Dim REGEX As Object, Matches As Object
Dim oFSO As Object, oFolder As Object, oFile As Object
Path = "D:\Personal\Stack Overflow\" 'Modify as necessary.
Pattern = "(Team-(\d+).txt)"
Set REGEX = CreateObject("VBScript.RegExp")
With REGEX
.Pattern = Pattern
.Global = True
.IgnoreCase = True
End With
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(Path)
For Each oFile In oFolder.Files
Set Matches = REGEX.Execute(oFile.Name)
For Each Match In Matches
Debug.Print Match.Value
Next Match
Next oFile
End Sub
This will print in your immediate window (Ctrl-G in the VBE) all the names of text files that don't have AAA or the like in their filenames. Tried and tested.
In a similar vein to Loop through files in a folder using VBA?
Use Dir to efficiently find the first group of files that match team-xxxx.txt
Then zero in on the wanted match which could either be done with
Like for a simple match
Regexp for a harder match
Exit the Dir list on a successful match
I went with the regexp.
code
Sub LoopThroughFiles()
Dim objRegex As Object
Dim StrFile As String
Dim bFound As Boolean
bFound = False
Set objRegex = CreateObject("VBScript.RegExp")
objRegex.Pattern = "team-\d+"
StrFile = Dir("c:\temp\team-*.txt")
Do While Len(StrFile) > 0
If objRegex.test(StrFile) = False Then
StrFile = Dir
Else
bFound = True
MsgBox "Your file is " & StrFile
Exit Do
End If
Loop
If Not bFound Then MsgBox "No Match", vbCritical
End Sub
Is this helping?:
Dir("Your_folder_path_ending_with_a_\" & "Team-(*).txt")
Going a bit more in-depth and using the folder content shown in the picture:
This sub will return all the file names that only contain "Team-(Random Number).txt":
Sub showFileName()
Dim FolderPath As String: FolderPath = "C:\test\"
Dim Filter As String: Filter = "Team-(*).txt"
Dim dirTmp As String
dirTmp = Dir(FolderPath & Filter)
Do While Len(dirTmp) > 0
Debug.Print dirTmp
dirTmp = Dir
Loop
End Sub
The result is:
Team-(123).txt
Team-(14).txt
Team-(PI).txt

VBA Excel get first file name from the files collection returned by GetFolder.Files

I'm trying to get the first file of a directory. I don't care that "first" is not well defined in this case, and I don't care if I'll get a different file each time I call my sub.
I try to use:
Dim FSO As Object
Dim SourceFolder As Object
Dim FileItem As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.GetFolder(SourceFolderName)
Set FileItem = SourceFolder.Files.Item(0)
but this returns a compiler error ("Invalid procedure call or argument")
Could you please tell me how to make this work?
Thanks,
Li
You may use the bulit in Dir function
Below is the sample code which returns the first file found name from Test folder.
Sub test()
Dim strFile As String
strFile = Dir("D:Test\", vbNormal)
End Sub
It looks to me like SourceFolder.Files will only accept a string as the key, just like you noted with Scripting.Folders. I think Santosh's answer is the way to go, but here's a kludgy modification of your code that returns the "first" file in the folder:
Sub test()
Dim FSO As Object
Dim SourceFolder As Object
Dim FileItem As Object
Dim FileItemToUse As Object
Dim SourceFolderName As String
Dim i As Long
SourceFolderName = "C:\Users\dglancy\Documents\temp"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.GetFolder(SourceFolderName)
For Each FileItem In SourceFolder.Files
If i = 0 Then
Set FileItemToUse = FileItem
Exit For
End If
Next FileItem
Debug.Print FileItemToUse.Name
End Sub
It’s true that VBA has a limitation (a bug or design flaw in my opinion) in which a file system object's Files collection cannot be accessed by item-index number, only by each item’s file-path string value. The original question posted here is about accessing only the first item in the Files collection but it touches on a general problem for which there are two reasonable workarounds: creation and use of either a File object meta-collection or a File object array to provide indexed access to a Files collection. Here’s a demo routine:
Sub DemoIndexedFileAccess()
'
'Demonstrates use of both a File object meta-collection and a File object array to provide indexed access
'to a Folder object's Files collection.
'
'Note that, in both examples, the File objects being accessed refer to the same File objects as those in
'the Folder object's Files collection. (i.e. if one of the physical files gets renamed after the creation
'of the Folder object's Files collection, all three sets of File objects will refer to the same, renamed
'file.)
'
'IMPORTANT: This technique requires a reference to "Microsoft Scripting Runtime" be set.
'
'**********************************************************************************************************
'File-selector dialog contsants for msoFileDialogFilePicker and msoFileDialogOpen:
Const fsdCancel As Integer = 0 'File dialog Cancel button
Const fsdAction As Integer = -1 'File dialog Action button, and its aliases...
Const fsdOpen As Integer = fsdAction
Const fsdSaveAs As Integer = fsdAction
Const fsdOK As Integer = fsdAction
Dim FD As FileDialog
Dim File As Scripting.File
Dim FileArr() As Scripting.File
Dim FileColl As New Collection
Dim Folder As Scripting.Folder
Dim FSO As Scripting.FileSystemObject
Dim Idx As Integer
'Get a folder specification from which files are to be processed
Set FD = Application.FileDialog(msoFileDialogFolderPicker) 'Create the FolderPicker dialog object
With FD
.Title = "Select Folder Of Files To Be Processed"
.InitialFileName = CurDir
If .Show <> fsdOK Then Exit Sub
End With
'Use the folder specification to create a Folder object.
Set FSO = New Scripting.FileSystemObject
Set Folder = FSO.GetFolder(FD.SelectedItems(1))
'A Folder object's Files collection can't be accessed by item-index number (only by each item's file-path
'string value), so either...
'1. Create a generic "meta-collection" that replicates the Files collection's File objects, which allows
' access by collection-item index:
For Each File In Folder.Files
FileColl.Add File
Next File
'"Process" the files in (collection) index order
For Idx = 1 To FileColl.Count
Debug.Print "Meta-Collection: " & FileColl(Idx).Name
Next Idx
'2. Or, create an array of File objects that refer to the Files collection's File objects, which allows
' access by array index:
ReDim FileArr(1 To Folder.Files.Count)
Idx = 1
For Each File In Folder.Files
Set FileArr(Idx) = File
Idx = Idx + 1
Next File
'"Process" the files in (array) index order
For Idx = LBound(FileArr) To UBound(FileArr)
Debug.Print "File Object Array: " & FileArr(Idx).Name
Next Idx
End Sub
I solve the problem in this Way:
Private Function GetFirstFile(StrDrive as String) As String
'Var Declarations
Dim Fso As Object, Drive As Object, F As File
'Create a reference to File System Object and Drive
Set Fso = New Scripting.FileSystemObject
Set Drive = Fso.GetDrive(StrDrive)
If Not Drive Is Nothing Then
'Scan files in RootFolder.files property of then drive object
For Each F In Drive.RootFolder.Files
Exit For
Next
'if there are any file, return the first an get then name
If Not F Is Nothing Then FirstFile = F.Name: Set F = Nothing
Set Drive = Nothing
End If
Set Fso = Nothing
End Function
Don´t forget add Reference to Microsoft Scripting Runtime in your project
It works to me... I hope this Help you guys.
Why don't you just use a function to iterate through the files in the folder until you get to the one that you want? Assuming you're using the fso as detailed in other posts above, just pass the Folder, and the Index of the file you want, it could be #1 or any other file in the folder.
Function GetFile(oFolder As Folder, Index As Long) As File
Dim Count As Long
Dim oFile As File
Count = 0
For Each oFile In oFolder.Files
Count = Count + 1
If Count = Index Then
Set GetFile = oFile
Exit Function
End If
Next oFile
End Function

Excel Macro to apend data from two notepad into a single notepad

I want to delete the last line contain '*' of two notepad and apend the reamining data into a new notepad by excel macro.
Please guys help me out. I can't find any suggestion.
Using #mehow's suggestion, here is some code that you can use:
' To get this to run, you'll need to reference Microsoft Scripting Runtime:
' Per http://stackoverflow.com/questions/3233203/how-do-i-use-filesystemobject-in-vba
' Within Excel you need to set a reference to the VB script run-time library. The relevant file is usually located at \Windows\System32\scrrun.dll
' To reference this file, load the Visual Basic Editor (ALT-F11)
' Select Tools - References from the drop-down menu
' A listbox of available references will be displayed
' Tick the check-box next to 'Microsoft Scripting Runtime'
' The full name and path of the scrrun.dll file will be displayed below the listbox
' Click on the OK button
Sub appFiles()
'File path and names for each file
Dim sFile1 As String
Dim sFile2 As String
Dim sFileLast As String
'Search string
Dim sSearchStr As String
'Delimiter used to separate/join lines
Dim sDL As String
'If the final file already exists, should it overwrite the previous _
contents (True) or append to the end of the file (False)
Dim doOverwrite As Boolean
'File contents
Dim sMsg1 As String
Dim sMsg2 As String
Dim sMsgFinal As String
sFile1 = "C:\Users\foobar\Desktop\foo.txt"
sFile2 = "C:\Users\foobar\Desktop\foo2.txt"
sFileLast = "C:\Users\foobar\Desktop\fooFinal.txt"
sSearchStr = "*"
sDL = Chr(13) & Chr(10)
doOverwrite = True
sMsg1 = appendLines(sFile1, sSearchStr, sDL)
sMsg2 = appendLines(sFile2, sSearchStr, sDL)
sMsgFinal = sMsg1 & sDL & sMsg2
Call writeToFile(sMsgFinal, sFileLast, doOverwrite)
End Sub
Function appendLines(sFileName As String, sSearchStr As String, Optional sDL As String = " ") As String
Dim oFSO As FileSystemObject
Set oFSO = New FileSystemObject
Dim oFS As TextStream
Dim sStr As String
Dim sMsg As String
If oFSO.fileexists(sFileName) Then 'Check if file exists
On Error GoTo Err
Set oFS = oFSO.openTextFile(sFileName)
'Read file
Do While Not oFS.AtEndOfStream
sStr = oFS.ReadLine
If InStr(sStr, sSearchStr) Then
appendLines = sMsg
Else
sMsg = sMsg & sStr & sDL
End If
Loop
oFS.Close
Else
Call MsgBox("The file path (" & sFileName & ") is invalid", vbCritical)
End If
Set oFS = Nothing
Set oFSO = Nothing
Exit Function
Err:
Call MsgBox("Error occurred while reading the file.", vbCritical)
oFS.Close
Set oFS = Nothing
Set oFSO = Nothing
End Function
Sub writeToFile(sMsg As String, sFileName As String, Optional doOverwrite As Boolean = False)
Dim oFSO As FileSystemObject
Set oFSO = New FileSystemObject
Dim oFS As TextStream
On Error GoTo Err
If oFSO.fileexists(sFileName) Then
If doOverwrite Then
Set oFS = oFSO.openTextFile(sFileName, ForWriting)
Else
Set oFS = oFSO.openTextFile(sFileName, ForAppending)
End If
Else
Set oFS = oFSO.CreateTextFile(sFileName, True)
End If
Call oFS.write(sMsg)
oFS.Close
Set oFS = Nothing
Set oFSO = Nothing
Exit Sub
Err:
Call MsgBox("Error occurred while writing to the file.", vbCritical)
oFS.Close
Set oFS = Nothing
Set oFSO = Nothing
End Sub
You'll need to customize the appFiles routine as needed, by providing file names to sFile1, sFile2, and sFileLast; your desired search string to sSearchStr (you mentioned using "*"); a delimiter to separate lines (it's currently written to use a carriage return and new line); and a parameter deciding whether or not to overwrite the final file (if you find yourself running this multiple times with the same final file).
Here's another link that I used while writing the code above: link - Explains how to write to a file from within a macro
Hope this helps.

Outlook 2010 : coloring mail folders?

Any one knows how to get colored folders in Outlook 2010 ?
There is no such functionality integrated in Outlook... Is there another way ? VBA ? How does it works ?
Thanks.
No, colored folders in Outlook still have not been implemented.
I implemented a work-around basing on:
designing icons consisting of a colored square (red, blue, green, etc.)
storing icons in a defined local directory
assigning programmatically (VBA) the icons to the mail folders.
Result:
Example
HOWTO
Create icons files (e.g. red.ico, blue.ico) in C:\icons or unzip this file to C:\icons icons
Define the VBA code below and adapt the function ColorizeOutlookFolders according to your needs
Code:
Function GetFolder(ByVal FolderPath As String) As Outlook.folder
' Returns an Outlook folder object basing on the folder path
'
Dim TempFolder As Outlook.folder
Dim FoldersArray As Variant
Dim i As Integer
On Error GoTo GetFolder_Error
'Remove Leading slashes in the folder path
If Left(FolderPath, 2) = "\\" Then
FolderPath = Right(FolderPath, Len(FolderPath) - 2)
End If
'Convert folderpath to array
FoldersArray = Split(FolderPath, "\")
Set TempFolder = Application.Session.Folders.Item(FoldersArray(0))
If Not TempFolder Is Nothing Then
For i = 1 To UBound(FoldersArray, 1)
Dim SubFolders As Outlook.Folders
Set SubFolders = TempFolder.Folders
Set TempFolder = SubFolders.Item(FoldersArray(i))
If TempFolder Is Nothing Then
Set GetFolder = Nothing
End If
Next
End If
'Return the TempFolder
Set GetFolder = TempFolder
Exit Function
GetFolder_Error:
Set GetFolder = Nothing
Exit Function
End Function
Sub ColorizeOneFolder(FolderPath As String, FolderColour As String)
Dim myPic As IPictureDisp
Dim folder As Outlook.folder
Set folder = GetFolder(FolderPath)
Set myPic = LoadPicture("C:\icons\" + FolderColour + ".ico")
If Not (folder Is Nothing) Then
' set a custom icon to the folder
folder.SetCustomIcon myPic
'Debug.Print "setting colour to " + FolderPath + " as " + FolderColour
End If
End Sub
Sub ColorizeFolderAndSubFolders(strFolderPath As String, strFolderColour As String)
' this procedure colorizes the foler given by strFolderPath and all subfolfers
Dim olProjectRootFolder As Outlook.folder
Set olProjectRootFolder = GetFolder(strFolderPath)
Dim i As Long
Dim olNewFolder As Outlook.MAPIFolder
Dim olTempFolder As Outlook.MAPIFolder
Dim strTempFolderPath As String
' colorize folder
Call ColorizeOneFolder(strFolderPath, strFolderColour)
' Loop through the items in the current folder.
For i = olProjectRootFolder.Folders.Count To 1 Step -1
Set olTempFolder = olProjectRootFolder.Folders(i)
strTempFolderPath = olTempFolder.FolderPath
'prints the folder path and name in the VB Editor's Immediate window
'Debug.Print sTempFolderPath
' colorize folder
Call ColorizeOneFolder(strTempFolderPath, strFolderColour)
Next
For Each olNewFolder In olProjectRootFolder.Folders
' recursive call
'Debug.Print olNewFolder.FolderPath
Call ColorizeFolderAndSubFolders(olNewFolder.FolderPath, strFolderColour)
Next
End Sub
Sub ColorizeOutlookFolders()
Call ColorizeFolderAndSubFolders("\\Personal\Documents\000-Mgmt-CH\100-People", "blue")
Call ColorizeFolderAndSubFolders("\\Personal\Documents\000-Mgmt-CH\200-Projects", "red")
Call ColorizeFolderAndSubFolders("\\Personal\Documents\000-Mgmt-CH\500-Meeting", "green")
Call ColorizeFolderAndSubFolders("\\Personal\Documents\000-Mgmt-CH\800-Product", "magenta")
Call ColorizeFolderAndSubFolders("\\Personal\Documents\000-Mgmt-CH\600-Departments", "grey")
Call ColorizeFolderAndSubFolders("\\Mailbox - Dan Wilson\Inbox\Customers", "grey")
End Sub
To launch colorizing at Outlook startup, in the VBA object ThisOutlookSession, define the following function:
Private Sub Application_Startup()
ColorizeOutlookFolders
End Sub

Resources