Modif code arborescence fichier

[Aladin]

Bonjour le forum
J' ai recupéré le code suivant sur un post ou est intervenu BOIGONTIER

Const MaxNiv = 2
Sub arborescenceRepertoire()
  racine = ChoixDossier()     ' ou un répertoire C:\xxx e.g.
  If racine = "" Then Exit Sub
  Range("A:A").Clear
  Range("A3").Select
  Set fs = CreateObject("Scripting.FileSystemObject")
  Set dossier_racine = fs.getfolder(racine)
  Lit_dossier dossier_racine, 1
  Range("A1").Select
End Sub
Sub Lit_dossier(ByRef dossier, ByVal niveau)
   ActiveCell.Value = String(3 * niveau - 1, " ") & dossier.Name  '& "[" & dossier.Path & "]"
   ActiveCell.Offset(1, 0).Select
   For Each d In dossier.SubFolders
     If niveau <= MaxNiv Then Lit_dossier d, niveau + 1
   Next
End Sub
Function ChoixDossier()
    If Val(Application.Version) >= 10 Then
       With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ActiveWorkbook.Path & "\"
        .Show
        If .SelectedItems.Count > 0 Then
           ChoixDossier = .SelectedItems(1)
        Else
           ChoixDossier = ""
        End If
       End With
     Else
       ChoixDossier = InputBox("Répertoire?")
     End If
End Function

Ne serait il pas posssible de mettre en gras avec une couleur differente les soms des repertoires afin de faire une séparation, mes competences sont limité pour faire cette modif

Merci d'avance pour vos réponses
Aladin

 

[kiki29]

Re : Modif code arborescence fichier

Salut, à adapter mais pour cela tu as le macro recorder

Option Explicit

Dim Nb As Long
Const MaxNiv = 3

Sub arborescenceRepertoire()
Dim Racine As String
Dim FS As Object, dossier_racine As Object

    Racine = ChoixDossier()
    If Racine = "" Then Exit Sub
    Range("A:A").Clear
    Range("A3").Select
    Set FS = CreateObject("Scripting.FileSystemObject")
    Set dossier_racine = FS.getfolder(Racine)

    Application.ScreenUpdating = False
    Lit_dossier dossier_racine, 1
    Application.ScreenUpdating = True

    Set dossier_racine = Nothing
    Set FS = Nothing
    
    Range("A1").Select
End Sub

Private Function ChoixDossier()
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ActiveWorkbook.Path & "\"
        .Show
        If .SelectedItems.Count > 0 Then
            Nb = 0
            ChoixDossier = .SelectedItems(1)
        End If
    End With
End Function

Private Sub Lit_dossier(ByRef dossier, ByVal niveau)
Dim d As Object

    Nb = Nb + 1
    ActiveCell.Value = String(3 * niveau - 1, " ") & dossier.Name
    Select Case niveau
        Case 1
            With ActiveCell
                .Font.Bold = True
                .Font.ColorIndex = 9
            End With
        Case 2
            With ActiveCell
                .Font.Bold = False
                .Font.ColorIndex = 45
            End With
        Case 3
            With ActiveCell
                .Font.Bold = False
                .Font.ColorIndex = 41
            End With
        Case 4
            With ActiveCell
                .Font.Bold = False
                .Font.ColorIndex = 50
            End With
            '   ..... etc
    End Select

    ActiveCell.Offset(1, 0).Select
    Application.StatusBar = Nb
    
    For Each d In dossier.SubFolders
        If niveau <= MaxNiv Then Lit_dossier d, niveau + 1
    Next d
    
    Set d = Nothing
End Sub

 

[Aladin]

Re : Modif code arborescence fichier

Bonjour le forum et kiki29

Merci pour ta réponse et la modif, test ok

Aladin