This VBA function uses the FileSystemObject to create a folder if it does not already exist. If the folder is several subfolders deep, it creates all of the subfolders as well.
As an example, you could call this function to create an employee folder on the network when you enter an employee record into a Microsoft Access form. After the folder is created, you could also add a set of subfolders.
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 CreateAFolder(FolderPath As String) As Boolean ' This procedure creates the FolderPath if it does not already exist. ' ' CreateAFolder() 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 avarFolders Dim intElem As Integer Dim strFolderPath As String Dim strFolder As String Dim strPath As String Dim strCombined As String If fso.FolderExists(FolderPath) Then ' The folder already exists. No need to continue. CreateAFolder = True GoTo Exit_Proc End If strFolderPath = FolderPath If Left(strFolderPath, 2) = "\\" Then strCombined = "\\" ' Strip off the network drive back slashes because we'll use ' a backslash to split out the array. strFolderPath = Right(strFolderPath, Len(strFolderPath) - 2) Else strCombined = "" End If ' Create the array of folders. avarFolders = Split(strFolderPath, "\") ' Loop through the array and create folders that are missing. For intElem = 0 To UBound(avarFolders) ' Get the folder. Add it to the combined path. strFolder = avarFolders(intElem) strCombined = strCombined & "\" & strFolder ' If this is not the drive, then look for the folder. If intElem > 0 Then strPath = Right(strCombined, Len(strCombined) - 1) If Not fso.FolderExists(strPath) Then ' Create the folder because it does not exist. fso.CreateFolder (strPath) End If End If Next intElem CreateAFolder = True Exit_Proc: On Error Resume Next Set fso = Nothing Exit Function Err_Handler: MsgBox Err.Number & " " & Err.Description, vbCritical, _ "CreateAFolder()" CreateAFolder = False Resume Exit_Proc Resume End Function