Code VBA du dossier contenu dans la bibliothèque

La bibliothèque de code VBA contient du code relatif aux dossiers : deux extraits pour boucler un dossier, une fonction FolderExists et une procédure pour créer un dossier avec des sous-dossiers.

L'image de droite montre le menu Code VBA " VBA " Dossier où les éléments de la bibliothèque VBA se trouvent en bas. Les autres éléments sont des procédures de dossier VBA standard et un outil spécial permettant de créer facilement une chaîne de dossier.

• Remplir un tableau avec des sous-dossiers en utilisant Dir
• Boucler les dossiers à l'aide de Dir
• Vérifier si un dossier existe
• Créer plusieurs répertoires imbriqués

Remplir un tableau avec des sous-dossiers en utilisant Dir

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

Boucler les dossiers à l'aide de Dir

Dim strItemInFolder As String
strItemInFolder = Dir(, vbDirectory)
Do While strItemInFolder <> ""
    Si ((GetAttr( & strItemInFolder) And vbDirectory) = vbDirectory) And _
        Not (strItemInFolder = "." Or strItemInFolder = "") Then
        'TODO : remplacez Debug.Print par le processus que vous voulez effectuer sur le sous-dossier
        Dim strFilePath As String : strFilePath = strFolder & strItemInFolder
        Debug.Print strItemInFolder
    Fin Si
    strItemInFolder = Dir
Loop

Vérifier si un dossier existe

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

Créer plusieurs répertoires imbriqués

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