Microsoft 365 LISTBOX REPERTOIRE ET SOUS REPERTOIRE

Regueiro · 25 Novembre 2020

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

ChTi160 · 25 Novembre 2020

Bonjour Regueiro
Pas sur d'être a la hauteur mais voilà ce que j'ai fais et qui semble fonctionner Lol
jean marie

patricktoulon · 25 Novembre 2020

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

ChTi160 · 25 Novembre 2020

Bonjour Patrick
merci de ces infos et conseils.
Peut être aussi que les dossiers cibles ont un contenu bien défini , limité ??????
Bonne journée
Jean marie

patricktoulon · 25 Novembre 2020

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

ChTi160 · 25 Novembre 2020

Re
Merci Patrick
jean marie

Regueiro · 25 Novembre 2020

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"

ChTi160 · 25 Novembre 2020

Re
Tu dis:

VB:

Rép : avait 2 x le dernier dossier en variable

voir le code du fichier #2
Bonne fin de journée
Jean marie

Regueiro · 25 Novembre 2020

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

ChTi160 · 25 Novembre 2020

Re
ok ! A quoi correspondent ces cellules cibles(choisies)?
Jean marie

Regueiro · 25 Novembre 2020

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 :

Chantier	Désignation	CONTRAT HT	AVENANTS HT	TOTAL HT

	Report du tableau de facturation 2019

2018.068	XLD FRANCE	100.00	100.00	200.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.112	XXX Suisse	100'000.00	3500.00	103'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.012	CHTI CHANTIER VILLA FRANCE	30'000.00		30'000.00
	Prix Revient 2018 - Néant
	Prix Revient 2019 - 04.02.2019 au 22.11.2019
	Total Prix Revient

modus57 · 8 Janvier 2022

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 · 8 Janvier 2022

Bonsoir modus57
"liste1" est une ListBox ! Tout comme ""liste2"
Pas de fichier ?
Bonne soirée
Jean marie

modus57 · 9 Janvier 2022

Bonjour ChTi60,

Merci de réponde de nouveau à cette discussion.

Ci-joint mon fichier, @+

ChTi160 · 9 Janvier 2022

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

Microsoft 365 LISTBOX REPERTOIRE ET SOUS REPERTOIRE

Regueiro

XLDnaute Impliqué

Pièces jointes

ChTi160

XLDnaute Barbatruc

Pièces jointes

patricktoulon

XLDnaute Barbatruc

ChTi160

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

ChTi160

XLDnaute Barbatruc

Regueiro

XLDnaute Impliqué

ChTi160

XLDnaute Barbatruc

Regueiro

XLDnaute Impliqué

ChTi160

XLDnaute Barbatruc

Regueiro

XLDnaute Impliqué

modus57

XLDnaute Occasionnel

ChTi160

XLDnaute Barbatruc

modus57

XLDnaute Occasionnel

Pièces jointes

ChTi160

XLDnaute Barbatruc

Pièces jointes

Discussions similaires