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