VBA创建嵌套目录

VBA中如果需要创建嵌套目录必需逐级创建，而无法一次就完成，使得创建具有较深层次的目录时比较麻烦，这里水文工具集给出一个VBA过程MakeMultiStepDirectory实现创建嵌套目录的功能，使用这一VBA过程可以直接创建具有任意深度的文件夹，如：

MakeMultiStepDirectory C:\CnHUP.com\MyApplication\Settings\Templates\VB

同时它不仅能够建立本机的目录，还可以创建共享文件夹，具体VBA实现代码如下：

Option Explicit
'================================
' VBA实现创建嵌套目录
'
' http://cnhup.com
'================================
Public Enum EMakeDirStatus
    ErrSuccess = 0
    ErrRelativePath
    ErrInvalidPathSpecification
    ErrDirectoryCreateError
    ErrSpecIsFileName
    ErrInvalidCharactersInPath
End Enum
Const MAX_PATH = 260

Function MakeMultiStepDirectory(ByVal PathSpec As String) As EMakeDirStatus
    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