505.369.1650 [email protected]

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)
        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

    On Error Resume Next
    Set fso = Nothing
    Exit Function

    MsgBox Err.Number & " " & Err.Description, vbCritical, _
    CreateAFolder = False
    Resume Exit_Proc
End Function