For example, let’s say that you already have a folder for each employee under the Employees folder on the network. But then you decide that you would like to have NDA and Payroll subfolders beneath each employee folder. Calling this function would add those subfolders beneath each employee folder automatically.
Step 1
Have employee folders in place. Perhaps your work process in Microsoft Access creates an employee folder automatically each time you add an employee record:
D:\Code Test\Employees\John Doe
D:\Code Test\Employees\Mary Smith
Step 2
Create the EmployeeMaster folder and subfolders, something like this:
D:\Code Test\EmployeeMaster\NDA
D:\Code Test\EmployeeMaster\Payroll
Step 3
Call the function in the Immediate window:
?CopySetOfFolders("D:\Code Test\EmployeeMaster","D:\Code Test\Employees")
Results
These new folders will be added:
D:\Code Test\Employees\John Doe\NDA
D:\Code Test\Employees\John Doe\Payroll
D:\Code Test\Employees\Mary Smith\NDA
D:\Code Test\Employees\Mary Smith\Payroll
This function uses the FileSystemObject, so you will need to set a reference to Microsoft Scripting Runtime in the VBA editor (Tools, References).
Public Function CopySetOfFolders(MasterFolder As String, _
RootFolder As String) As Boolean
' This procedure copies all of the folders from MasterFolder to
' all of the folders in the RootFolder (some can be excluded
' in the SELECT CASE).
'
' CopySetOfFolders() Version 1.0.0
' Copyright © 2023 Extra Mile Data, www.extramiledata.com.
' For questions or issues, please contact [email protected].
' Use (at your own risk) and modify freely as long as proper credit is given.
'
On Error GoTo Err_Handler
Dim fso As New FileSystemObject
Dim fol As Folder
Dim astrFolders() As String
Dim lngElem As Long
Dim strFromFolder As String
Dim strToFolder As String
' Initialize the array of folders.
ReDim astrFolders(100)
' Fill the array with all of the folder names from the MasterFolder.
lngElem = 0
For Each fol In fso.GetFolder(MasterFolder).SubFolders
astrFolders(lngElem) = fol.Name
lngElem = lngElem + 1
Next
' Redimension the array to just the list of folders that was created.
ReDim Preserve astrFolders(lngElem - 1)
' Loop through the folders in the RootFolder.
For Each fol In fso.GetFolder(RootFolder).SubFolders
Select Case fol.Name
Case "FolderB", "FolderC"
' Ignore these folders.
Case Else
Debug.Print fol.Path
' Loop through the folders in the array.
For lngElem = 0 To UBound(astrFolders)
' Using the folder name, build the original folder path
' and then the path it will get copied to.
strFromFolder = MasterFolder & "\" & astrFolders(lngElem)
strToFolder = fol.Path & "\" & astrFolders(lngElem)
' Copy the folder.
fso.CopyFolder strFromFolder, strToFolder
Next lngElem
End Select
Next fol
' Message the user.
MsgBox "Done"
CopySetOfFolders = True
Exit_Proc:
On Error Resume Next
Set fol = Nothing
Set fso = Nothing
Exit Function
Err_Handler:
MsgBox Err.Number & " " & Err.Description, vbCritical, _
"CopySetOfFolders()"
CopySetOfFolders = False
Resume Exit_Proc
End Function
Making Microsoft Access Work. Call (505) 369-1650.