Creating Folder structure

[yomero]

This is not my code. However it is sooo good an useful I wanted to re-post it here. I found it at this link: http://www.cpearson.com/excel/MakeDirMulti.aspx

Private Declare Function PathIsRelative Lib "Shlwapi" _
        Alias "PathIsRelativeA" (ByVal Path As String) As Long

    Public Enum EMakeDirStatus
        ErrSuccess = 0
        ErrRelativePath
        ErrInvalidPathSpecification
        ErrDirectoryCreateError
        ErrSpecIsFileName
        ErrInvalidCharactersInPath
    End Enum
    Const MAX_PATH = 260
    
    Function MakeMultiStepDirectory(ByVal PathSpec As String) As EMakeDirStatus
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' MakeMultiStepDirectory
    ' This function creates a series of nested directories. The parent of
    ' every directory is create before a subdirectory is created, allowing a
    ' folder path specification of any number of directories (as long as the
    ' total length is less than MAX_PATH.
    '
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
    Dim FSO As Scripting.FileSystemObject
    Dim DD As Scripting.Drive
    Dim B As Boolean
    Dim Root As String
    Dim DirSpec As String
    Dim N As Long
    Dim M As Long
    Dim S As String
    Dim Directories() As String
        
    Set FSO = New Scripting.FileSystemObject
        
    ' ensure there are no invalid characters in spec.
    On Error Resume Next
    Err.Clear
    S = Dir(PathSpec, vbNormal)
    If Err.Number <> 0 Then
        MakeMultiStepDirectory = ErrInvalidCharactersInPath
        Exit Function
    End If
    On Error GoTo 0
    
    ' ensure we have an absolute path
    B = CBool(PathIsRelative(PathSpec))
    If B = True Then
        MakeMultiStepDirectory = ErrRelativePath
        Exit Function
    End If
    
    ' if the directory already exists, get out with success.
    If FSO.FolderExists(PathSpec) = True Then
        MakeMultiStepDirectory = ErrSuccess
        Exit Function
    End If
    
    ' get rid of trailing slash
    If Right(PathSpec, 1) = "\" Then
        PathSpec = Left(PathSpec, Len(PathSpec) - 1)
    End If
    
    ' ensure we don't have a filename
    N = InStrRev(PathSpec, "\")
    M = InStrRev(PathSpec, ".")
    If (N > 0) And (M > 0) Then
        If M > N Then
            ' period found after last slash
            MakeMultiStepDirectory = ErrSpecIsFileName
            Exit Function
        End If
    End If
    
    If Left(PathSpec, 2) = "\\" Then
        ' UNC -> \\Server\Share\Folder...
        N = InStr(3, PathSpec, "\")
        N = InStr(N + 1, PathSpec, "\")
        Root = Left(PathSpec, N - 1)
        DirSpec = Mid(PathSpec, N + 1)
    Else
        ' Local or mapped -> C:\Folder....
        N = InStr(1, PathSpec, ":", vbBinaryCompare)
        If N = 0 Then
            MakeMultiStepDirectory = ErrInvalidPathSpecification
            Exit Function
        End If
        Root = Left(PathSpec, N)
        DirSpec = Mid(PathSpec, N + 2)
    End If
    Set DD = FSO.GetDrive(Root)
    Directories = Split(DirSpec, "\")
    DirSpec = DD.Path
    For N = LBound(Directories) To UBound(Directories)
        DirSpec = DirSpec & "\" & Directories(N)
        If FSO.FolderExists(DirSpec) = False Then
            On Error Resume Next
            Err.Clear
            FSO.CreateFolder (DirSpec)
            If Err.Number <> 0 Then
                MakeMultiStepDirectory = ErrDirectoryCreateError
                Exit Function
            End If
        End If
    Next N
    MakeMultiStepDirectory = ErrSuccess
    End Function
'You can then call this code from your own code as follows:

    Sub AAA()
        Dim Result As EMakeDirStatus
        Result = MakeMultiStepDirectory("C:\One\Two\Three\Four")
        If Result = ErrSuccess Then
            Debug.Print "Success"
        Else
            Debug.Print "Error"
        End If
    End Sub