TopPicLogo TopPicText

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

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


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

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



Назад ToTop
L.E. 20.10.2012
Рейтинг@Mail.ru