如何使用FileSystemObject.CreateFolder同时创建文件夹及子文件夹

问题根因 #

FileSystemObject.CreateFolder 原生仅支持创建单级文件夹，调用时要求目标路径的所有上级父文件夹必须已存在，否则会直接抛出路径不存在错误，这就是MakeDir2直接运行报错的原因。

最优解决方案 #

封装通用的多级文件夹创建函数，后续任何需要创建多层目录的场景都可以直接调用，无需提前手动创建父级文件夹：

通用函数代码 #

' 传入完整文件夹路径，自动创建所有不存在的层级文件夹
Sub MakeMultiDir(ByVal FullPath As String)
    Dim FSO As FileSystemObject
    Dim PathArr As Variant
    Dim CurrentPath As String
    Dim i As Integer
    
    Set FSO = New FileSystemObject
    ' 统一处理路径分隔符，兼容斜杠输入
    FullPath = Replace(FullPath, "/", "\")
    ' 去掉路径末尾的反斜杠避免拆分异常
    If Right(FullPath, 1) = "\" Then FullPath = Left(FullPath, Len(FullPath) - 1)
    
    PathArr = Split(FullPath, "\")
    ' 从盘符开始逐层拼接创建
    CurrentPath = PathArr(0) & "\"
    For i = 1 To UBound(PathArr)
        CurrentPath = FSO.BuildPath(CurrentPath, PathArr(i))
        If Not FSO.FolderExists(CurrentPath) Then
            FSO.CreateFolder CurrentPath
        End If
    Next i
    Set FSO = Nothing
End Sub

调用示例 #

Sub MakeDir2() ' 改造后可直接正常运行
    Dim DocPath As String
    DocPath = "E:\@Workorders\test\test2\"
    ' 直接调用通用函数即可
    MakeMultiDir DocPath
End Sub

轻量替代方案 #

如果不需要复用逻辑，也可以直接调用Shell接口一行实现：

Sub MakeDir2_Lite()
    Dim DocPath As String
    DocPath = "E:\@Workorders\test\test2\"
    CreateObject("Shell.Application").Namespace("C:\").NewFolder DocPath
End Sub

内容的提问来源于stack exchange，提问作者user1636620