Microsoft 365 LISTBOX REPERTOIRE ET SOUS REPERTOIRE

Regueiro

XLDnaute Impliqué
Bonsoir le Forum
Petit problème pour alimenter la 2ème listbox en fonction du choix de la 1ère
Il bute sur chemin ( nothing )
Merci pour votre retour
VB:
Option Explicit
'VBA FileSystemObject (FSO)
'Outils - Références - Microsoft Scripting Runtime à activer
Dim FSO As FileSystemObject
Dim MYFILE As File
Dim DOSSIER As Folder
Dim SOUSDOS As Folder
Dim Chemin As Folder
Dim n As Integer
Dim racine As String
Private Sub b_debut_Click()
Set FSO = New Scripting.FileSystemObject

racine = ChoixDossier()     ' ou un répertoire C:\xxx e.g.
Set DOSSIER = FSO.GetFolder(racine)
Me.ListBox1.Clear

n = 0

Me.ListBox1.Clear
  For Each SOUSDOS In DOSSIER.SubFolders
       Me.ListBox1.AddItem SOUSDOS.Name                              'DOSSIER.Name
       Me.ListBox1.List(n, 1) = SOUSDOS.Path                                             'DOSSIER.Path
       n = n + 1
   Next
   Me.TextBox1 = DOSSIER.Path
   Me.TextBox2 = n & " Dossiers"
End Sub
Private Sub ListBox1_Click()
Dim rép

Dim F1 As Object
rép = Me.ListBox1.Column(1) & "\" & Me.ListBox1
  Set FSO = New Scripting.FileSystemObject
Set Chemin = FSO.GetFolder(rép)
  Me.ListBox2.Clear
  n = 0
  On Error Resume Next
  'For Each f1 In FSO.GetFolder(MonRepertoire).SubFolders
  For Each SOUSDOS In Chemin.SubFolders
    Me.ListBox2.AddItem Chemin.Name
    Me.ListBox2.List(n, 1) = Chemin.Path
    n = n + 1
  Next
  Me.TextBox1 = Chemin.Path
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
Private Sub UserForm_Initialize()
  racine = "c:\"
  Set FSO = CreateObject("Scripting.FileSystemObject")
  Set DOSSIER = FSO.GetFolder(racine)
  Me.ListBox1.Clear
  Me.ListBox2.Clear

  n = 0
  For Each SOUSDOS In DOSSIER.SubFolders
       Me.ListBox1.AddItem DOSSIER.Name
       Me.ListBox1.List(n, 1) = DOSSIER.Path
       n = n + 1
   Next
   Me.TextBox1 = DOSSIER.Path
  ' listefichiers DOSSIER.Path
End Sub
 

Pièces jointes

  • XLD REPERTOIRE.xlsm
    23.5 KB · Affichages: 21

patricktoulon

XLDnaute Barbatruc
bonjour
gérer dossier et sub dossier avec seulement 2 listbox me parait un peu leger
dans le sens ou un sub dossier en liste 2 peut lui aussi avoir un/des sub dossier a afficher dans un e eventuelles liste3
et on en fini plus
alors qu'avec une seule liste box et je dis bien une seul il t'est possible de descendre ou remonter l'arborescence d'un dossier exactement de la même manière que le fait l'explorateur windows
plus de soucis de limite de descente dans l'arborescence
 

patricktoulon

XLDnaute Barbatruc
bonjour ChTi160
oui donc un seule étage
dans ce cas la cela peut être fait en moins de 10 lignes avec dir et avec une fonction commune en plus

tiens un exemple en 4eme vitesse à main levée
1 userform
1 textbox "choix dossier"
1 commandbutton
2 listboxs "liste1" et "liste2"

et voila
tu click sur le bouton tu choisi ton dossier
et ca te le liste dans liste1
tu click sur un dossier dans liste1 ça te liste les sous dossiers (du dossier cliqué en liste 1) dans liste2

VB:
Option Explicit
Private Sub CommandButton1_Click()
    Choixdossier = ""
    liste1.Clear: liste2.Clear
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ActiveWorkbook.Path & "\"
        .Show
        If .SelectedItems.Count > 0 Then Choixdossier = .SelectedItems(1): Dir_Commun Choixdossier, liste1
    End With
End Sub

Function Dir_Commun(doss, liste As MSForms.ListBox)
  Dim dossiers$
   liste.Clear
  dossiers = Dir(doss & "\", vbDirectory)
     Do While dossiers <> ""
        If (GetAttr(doss & "\" & dossiers) And vbDirectory) = vbDirectory And Not Left(dossiers, 2) Like "*.*" Then liste.AddItem dossiers
        dossiers = Dir
    Loop
End Function

Private Sub liste1_Click()
Dir_Commun Choixdossier & "\" & liste1.Value, liste2
End Sub
pas besoins de sortir l'artillerie de scriptingfilesystem
;)
demo7.gif
 

Regueiro

XLDnaute Impliqué
Bonjour à Tous.
Merci pour vos réponses, je vais examiner cela ce soir
Il était un peu tard hier soir et la fatigue venant.
Par contre j'ai trouvé mon erreur de hier soir en rouge en rajoutant un msgbox
Rép : avait 2 x le dernier dossier en variable
Enrichi (BBcode):
Private Sub ListBox1_Click()
Dim rép
Dim SOUSDOS As Folder
rép = Me.ListBox1.Column(1) '& "\" & Me.ListBox1
MsgBox rép

  Set FSO = New Scripting.FileSystemObject
  Set DOSSIER = FSO.GetFolder(rép)
'Set Chemin = FSO.GetFolder(rép)
  Me.ListBox2.Clear
  n = 0
  'On Error Resume Next
  'For Each f1 In FSO.GetFolder(MonRepertoire).SubFolders
  For Each SOUSDOS In DOSSIER.SubFolders    'FSO.GetFolder(rép).SubFolders
  'Chemin.SubFolders
    Me.ListBox2.AddItem SOUSDOS.Name
    Me.ListBox2.List(n, 1) = SOUSDOS.Path
    n = n + 1
  Next
  Me.TextBox1 = DOSSIER.Path
  Me.TextBox2 = n & " Dossiers"
 

Regueiro

XLDnaute Impliqué
Merci ChTi160,
Je suis au Boulot, je n'avais pas ouvert ton fichier, Bien vu.
Pour information, le résultat final de ce fichier devrait être :
C:\xxx\xxx\Chantiers
Répertoire principal dans la Listbox1
2016 Chantiers
2017 Chantiers
2018 Chantiers
etc
Sous-Répertoire dans la Listbox2
2016.001 Bulle
2016.099 Charmey
2016.199 Vuadens
Etc
Après lorsque je clic sur la listBox2.
Récupérer la valeur de l'index, admettons
En A1 = 2016.001
En A2 = Bulle
L'idéal, que je puisse sélectionner une cellule avec inputbox
et transférer la valeur dans la cellule choisie
InputBox = C28 = 2016.001 et C29 = Bulle
Merci pour votre retour
 

Regueiro

XLDnaute Impliqué
Re
Admettons C28, la suivante dépend du nombre de ligne que je vais mettre,
entre ce chantier et le suivant voir cei-dessous un exemple aléatoire :
ChantierDésignationCONTRAT
HT
AVENANTS
HT
TOTAL
HT
Report du tableau de facturation 2019
2018.068XLD FRANCE100.00100.00200.00
Prix Revient 2018 - 18.05.2018 au 19.12.2018
Prix Revient 2019 - 14.01.2019 au 24.06.2019
blaaaa
Total Prix Revient
2018.112XXX Suisse100'000.003500.00103'5000
Prix Revient 2018 - 10.10.2018 au 17.12.2018
Prix Revient 2019 - 07.01.2019 au 18.10.2019
Total Prix Revient
2019.012CHTI CHANTIER VILLA FRANCE30'000.0030'000.00
Prix Revient 2018 - Néant
Prix Revient 2019 - 04.02.2019 au 22.11.2019
Total Prix Revient
 

modus57

XLDnaute Occasionnel
Bonsoir,

Je déterre cette discussion car je comptai me servir du code de Patrick TOULON, mais j'ai un petit soucis avec cette ligne:
VB:
If .SelectedItems.Count > 0 Then Choixdossier = .SelectedItems(1): Dir_Commun Choixdossier, liste1

Ça plante sur "liste1" et cela affiche le message suivant :
"Erreur de compilation : "Tye d'argument ByRef incompatible"

Comment corriger le problème.

Merci d'avance pour vos réponses.
 

ChTi160

XLDnaute Barbatruc
Bonjour
????????????????
jean marie
Ps:
peut être ??????
VB:
Private Sub CommandButton1_Click()
    Dim Choixdossier, liste1 as Object, liste2 as Object
    Choixdossier = ""
    Me.liste1.Clear: Me.liste2.Clear
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ActiveWorkbook.Path & "\"
        .Show
        If .SelectedItems.Count > 0 Then Choixdossier = .SelectedItems(1): Dir_Commun Choixdossier, Me.liste1
    End With
End Sub
Function Dir_Commun(doss, liste As MSForms.ListBox)
    Dim dossiers$
     Me.liste2.Clear
    dossiers = Dir(doss & "\", vbDirectory)
       Do While dossiers <> ""
          If (GetAttr(doss & "\" & dossiers) And vbDirectory) = vbDirectory And Not Left(dossiers, 2) Like "*.*" Then liste.AddItem dossiers
          dossiers = Dir
      Loop
End Function
Private Sub CommandButton2_Click()
    Dim Choixdossier
    Dir_Commun Choixdossier & "\" & Me.liste1.Value, Me.liste2
End Sub
 

Pièces jointes

  • Modu57_1.gif
    Modu57_1.gif
    825 KB · Affichages: 18

Discussions similaires

Réponses
2
Affichages
509

Statistiques des forums

Discussions
303 820
Messages
2 014 415
Membres
219 921
dernier inscrit
pascal77500