Проверка на наличие и создание папок произвольной вложенности

... перед копированием, перемещением или созданием файла


Пример использования:

Dim distPath As String
Dim i As Long
'Задаем путь назначения копируемого файла

    distPath = "C:\Temp\01\test1\test2\test3\DB002.mdb" 
    i = PrepareFoldersForPath(distPath)      'Проверяем....

    If i = 0 Then                            'Папка назначения существует или успешно создана
        FileCopy "C:\DB\DB001.mdb", distPath 'Можно спокойно копировать файл
    Else
        'тут надобна обработочка ....
        Exit Sub                             'Конец процедуры в случае ошибки...
    End If

Функция:

Public Function PrepareFoldersForPath(strFilePath As String) As Long
'es 20.10.2018
'Проверка на наличие и создание папок произвольной вложенности перед копированием, перемещением или созданием файла
'В случае возникновения ошибки возвращает ее код
'--------------------------------------------------------------------
'Аргументы:
'   strFilePath = Полный путь к файлу (не к папке!)
'--------------------------------------------------------------------
Dim i As Integer
Dim x As Integer
Dim strTemp As String
Dim curPath As String
'--------------------------------------------------------------------------
On Error GoTo PrepareFoldersForPath_Err
    x = Len(strFilePath)

On Error Resume Next
    For i = 4 To x 'с четвёртого символа на случай сетевого пути с "\\X\"
        If Mid(strFilePath, i, 1) = "\" Then
            Err.Clear
            curPath = Mid(strFilePath, 1, i) 'можно i - 1
            'Debug.Print curPath
            If Dir(curPath, vbDirectory) = "" Then
                'Debug.Print "Создаю папку: " & curPath
                MkDir curPath
                'Debug.Print "Err: " & Err.Number
                DoEvents
            End If
        End If
    Next i
    PrepareFoldersForPath = Err.Number
    Err.Clear
    
PrepareFoldersForPath_End:
    Exit Function

PrepareFoldersForPath_Err:
    MsgBox "Error: " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
    "in Function: PrepareFoldersForPath ", vbCritical, "Error in Application"
    PrepareFoldersForPath = Err.Number
    Err.Clear
    Resume PrepareFoldersForPath_End

End Function