Option Explicit

Private Const INVALID_FILE_ATTRIBUTES As Long = -1

Private Declare Function CreateDirectory Lib "kernel32" Alias "CreateDirectoryA" (ByVal lpPathName As String, lpSecurityAttributes As Any) As Long

Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long

 

' Данная функция создает вложенные папки

' Она работает так MkDir_SS("C:\eto\papkaetvertogo\urovnya")

Sub MkDir_SS(ByVal p$)

    'On Error Resume Next

    Dim tmp$, Tp$()

    tmp = vbNullString

    p = RCP(VBA.Trim$(p))

    Tp = Split(p, "\")

    Dim i As Long

    tmp = Tp(0) & "\"

    For i = 1 To UBound(Tp) - 1

        tmp = tmp & Tp(i) & "\"

        If Not FolderExists(tmp) Then

            Call CreateDirectory(tmp, ByVal 0&)

            If Err.LastDllError <> 0 Then

                Err.Raise 1, , "Can't created folder."

            End If

        End If

    Next

End Sub

 

Public Function FolderExists(ByVal strFolderName As String) As Boolean

    FolderExists = GetFileAttributes(strFolderName) <> INVALID_FILE_ATTRIBUTES

End Function

 

' Всегда возвращает строку со слешем на конце.

Public Function RCP(ByVal path As String) As String

    RCP = path & IIf(VBA.Right$(path, 1) = "\", vbNullString, "\")

End Function