VBA, MS Access MS Access в примерах

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

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


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

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)
    For i = 1 To x
        If Mid(strFilePath, i, 1) = "\" Then
            curPath = Mid(strFilePath, 1, i - 1)
            Debug.Print curPath
            If Dir(curPath, vbDirectory) = "" Then
                Debug.Print "Создаю папку: " & curPath
                MkDir curPath
            End If
        End If
    Next i

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

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