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

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


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

Dim distPath As String

Dim i As Long

'Задаем путь назначения копируемого файла

distPath = "C:\Temp\01\test1\test2\test3\DB002.mdb"

i = FoldersPrepare(distPath) 'Проверяем....

If i = 0 Then 'Папка назначения существует или успешно создана

FileCopy "C:\DB\DB001.mdb", distPath 'Можно спокойно копировать файл

Else

'тут надобна обработочка ....

Exit Sub 'Конец процедуры в случае ошибки...

End If

Функция:

Public Function FoldersPrepare(strFilePath As String) As Long

'es 20.01.04

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

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

'В случае возникновения ошибки возвращает ее код

'--------------------------------------------------------------------

Dim i As Integer

Dim x As Integer

Dim strTemp As String

Dim curPath As String

On Error GoTo FoldersPrepareErr

x = Len(strFilePath)

For i = 1 To x

If Mid(strFilePath, i, 1) = "\" Then

curPath = Mid(strFilePath, 1, i - 1)

If Dir(curPath, vbDirectory) = "" Then

MkDir curPath

End If

End If

Next i

Exit Function

FoldersPrepareErr:

FoldersPrepare = Err.Number

Err.Clear

End Function