Carpeta de código VBA contenida en la biblioteca

La biblioteca de código VBA contiene código relacionado con las carpetas: dos fragmentos para hacer un bucle en una carpeta, una función FolderExists y un procedimiento para crear carpetas con subcarpetas.

La imagen de la derecha muestra el menú Código VBA " VBA " Carpeta donde los elementos de la biblioteca VBA están en la parte inferior. Los otros elementos son procedimientos estándar de carpetas VBA y una herramienta especial para crear fácilmente una cadena de carpetas.

• Rellenar array con subcarpetas utilizando Dir
• Carpetas en bucle mediante Dir
• Comprobar si existe una carpeta
• Crear varios directorios anidados

Rellenar array con subcarpetas utilizando Dir

Dim strItemInFolder As String
Dim FolderList() As String 'The array with found folders
Dim intFoundFolders As Integer
strItemInFolder = Dir(vbDirectory)
Do Mientras strItemInFolder <> ""
    If ((GetAttr(strFolder & strItemInFolder) And vbDirectory) = vbDirectory) And _
        Not (strItemInFolder = "." Or strItemInFolder = "..") Then
            ReDim Preserve FolderList(intFoundFolders)
            FolderList(intCarpetasEncontradas) = strItemInFolder
            intCarpetasEncontradas = intCarpetasEncontradas + 1
    Fin If
    strItemInFolder = Dir
Bucle

Carpetas en bucle mediante Dir

Dim strItemInFolder As String
strItemInFolder = Dir(vbDirectory)
Do Mientras strItemInFolder <> ""
    If ((GetAttr( & strItemInFolder) And vbDirectory) = vbDirectory) And _
        Not (strItemInFolder = "." Or strItemInFolder = "") Then
        TODO: reemplace Debug.Print por el proceso que desee realizar en la subcarpeta
        Dim strFilePath As String: strFilePath = strFolder & strItemInFolder
        Debug.Print strItemInFolder
    Fin If
    strItemInFolder = Dir
Bucle

Comprobar si existe una carpeta

Public Function FolderExists(Directory As String) As Boolean
    If Len(Dir(Directory, vbDirectory)) > 0 Then
        If GetAttr(Directory) = vbDirectory Then
            FolderExists = True
        End If
    End If
End Function

Crear varios directorios anidados

Public Function MakeDirMulti(DirSpec As String) As Boolean
'Creates multiple nested directories. (Author C Pearson)
'This is a replacement function for the VBA MkDir function. MkDir
' will create only the last (right-most) directory of a
' path specification, and all directories to the left of the
' last director must already exist. For example, the following will fail
'       MkDir "C:\Folder\Subfolder1\Subfolder2\Subfolder3"
' will fail unless "C:\Folder\Subfolder1\Subfolder2\" already
' exists. MakeDirMulti will create all the folders in
' "C:\Folder\Subfolder1\Subfolder2\Subfolder3" as required.
' If a "\\" string is found, it is converted to "\".
' At present, MakeDirMulti supports local and mapped drives,
' but not UNC paths.
' The function will return True even if no directories were
' created (all directories in DirSpec already existed).
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim Ndx As Long
    Dim Arr As Variant
    Dim DirString As String
    Dim TempSpec As String
    Dim DirTestNeeded As Boolean
    
    ''''''''''''''''''''''''''''''''
    ' Ensure DirSpec is valid.
    ''''''''''''''''''''''''''''''''
    If Trim(DirSpec) = vbNullString Then
        MakeDirMulti = False
        Exit Function
    End If
    If Len(DirSpec) > MAX_PATH Then
        MakeDirMulti = False
        Exit Function
    End If
    If Not ((Mid(DirSpec, 2, 1) = ":") Or (Mid(DirSpec, 3, 1) = ":")) Then
        MakeDirMulti = False
        Exit Function
    End If
    
    '''''''''''''''''''''''''''''''''''''
    ' Set DirTestNeeded to True. This
    ' indicates that we need to test to
    ' see if a folder exists. Once we
    ' create the first directory, there
    ' will no longer be a need to call
    ' Dir to see if a folder exists, since
    ' the newly created directory will, of
    ' course, have no existing subfolders.
    ''''''''''''''''''''''''''''''''''''''
    DirTestNeeded = True
    TempSpec = DirSpec
    '''''''''''''''''''''''''''''''''''''
    ' If there is a trailing \ character,
    ' delete it.
    '''''''''''''''''''''''''''''''''''''
    If Right(TempSpec, 1) = "\" Then
        TempSpec = Left(TempSpec, Len(TempSpec) - 1)
    End If
    
    '''''''''''''''''''''''''''''''''
    ' Split DirSpec into an array,
    ' delimited by "\".
    '''''''''''''''''''''''''''''''''
    Arr = Split(expression:=TempSpec, delimiter:="\")
    ''''''''''''''''''''''''''''''''''''
    ' Loop through the array, building
    ' up DirString one folder at a time.
    ' Each iteration will create
    ' one directory, moving left to
    ' right if the folder does not already
    ' exist.
    ''''''''''''''''''''''''''''''''''''
    For Ndx = LBound(Arr) To UBound(Arr)
        '''''''''''''''''''''''''''''''''
        ' If this is the first iteration
        ' of the loop, just take Arr(Ndx)
        ' without prefixing it with the
        ' existing DirString and path
        ' separator.
        '''''''''''''''''''''''''''''''''
        If Ndx = LBound(Arr) Then
            DirString = Arr(Ndx)
        Else
            DirString = DirString & Application.PathSeparator & Arr(Ndx)
        End If
        On Error GoTo ErrH:
        ''''''''''''''''''''''''''''''''''
        ' Only call the Dir function
        ' if we have yet to create a
        ' new directory. Once we create
        ' a new directory, we no longer
        ' need to call Dir, since the
        ' newly created folder will, of
        ' course, have no subfolders.
        '''''''''''''''''''''''''''''''''
        If DirTestNeeded = True Then
            If Dir(DirString, vbDirectory + vbSystem + vbHidden) = vbNullString Then
                DirTestNeeded = False
                MkDir DirString
            End If
        Else
            MkDir DirString
        End If
        On Error GoTo 0
    Next Ndx
    
    MakeDirMulti = True
    Exit Function
    
    ErrH:
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' If an error occured, typically because an invalid
    ' character was encountered in a directory name, return
    ' False.
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    MakeDirMulti = False
End Function