Transfert plusieurs listboxs par glisser-déposer
Bonjour à tous !
Dans le cadre d'un projet de gestion de personnel, j'aimerais réaliser un planning par drag & drop pour glisser les noms d'une listbox à une autre.
J'ai trouvé un exemple sur le site de Boisgontier qui fonctionne très bien avec 2 listboxs.
Le souci c'est que j'en ai 10...
Je joins un fichier d'exemple avec 4 listboxs, le drag&drop marche entre les 2 listboxs du haut.
Comment l'adapter à un plus grand nombre de listboxs ?
Merci d'avance pour votre aide, bonne journée !
Bonjour,
Je n'ai pas utilisé le code de Jacques mais celui que j'avais fait il y a bien longtemps qui est grosso-modo le même !
Le secret, pour que la cible soit la bonne, réside dans la propriété "Object" de la propriété "ActiveControl".
j'ai créé trois procédures communes à toutes les ListBox, par contre, les trois procédures événementielles qui gè. re le Glisser/Déposer doivent être utilisées pour chaque ListBox. Je vais regarder pour en faire un module de classe mais en, attendant, voici le code pour 10 ListBox nommées "ListBox1", "ListBox2", etc...
Donc, pour le test, tu poses 10 ListBox sur un UserForm, tu colles le code ci-dessous dans son module puis tu lance pour voir le résultat. Seule la ListBox1 est remplie d'éléments que tu peu balader d'une ListBox à une autre :
Private Sub UserForm_Activate()
Dim I As Integer
With Me.ListBox1
.ColumnCount = 2
For I = 1 To 10: .AddItem "Essai" & I: .Column(1, I - 1) = "Choix" & I: Next I
End With
For I = 2 To 10: Controls("ListBox" & I).ColumnCount = 2: Next I
End Sub
Private Sub ListBox1_MouseMove(ByVal Button As Integer, _
ByVal Shift As Integer, _
ByVal X As Single, _
ByVal Y As Single)
SourisBouge ListBox1, Button
End Sub
Private Sub ListBox1_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, _
ByVal Action As MSForms.fmAction, _
ByVal Data As MSForms.DataObject, _
ByVal X As Single, _
ByVal Y As Single, _
ByVal Effect As MSForms.ReturnEffect, _
ByVal Shift As Integer)
AvantDePoser ListBox1, Cancel, Effect, Data
End Sub
Private Sub ListBox1_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, _
ByVal Data As MSForms.DataObject, _
ByVal X As Single, _
ByVal Y As Single, _
ByVal DragState As MSForms.fmDragState, _
ByVal Effect As MSForms.ReturnEffect, _
ByVal Shift As Integer)
AvantDeGlisser Cancel, Effect
End Sub
Private Sub ListBox2_MouseMove(ByVal Button As Integer, _
ByVal Shift As Integer, _
ByVal X As Single, _
ByVal Y As Single)
SourisBouge ListBox2, Button
End Sub
Private Sub ListBox2_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, _
ByVal Action As MSForms.fmAction, _
ByVal Data As MSForms.DataObject, _
ByVal X As Single, _
ByVal Y As Single, _
ByVal Effect As MSForms.ReturnEffect, _
ByVal Shift As Integer)
AvantDePoser ListBox2, Cancel, Effect, Data
End Sub
Private Sub ListBox2_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, _
ByVal Data As MSForms.DataObject, _
ByVal X As Single, _
ByVal Y As Single, _
ByVal DragState As MSForms.fmDragState, _
ByVal Effect As MSForms.ReturnEffect, _
ByVal Shift As Integer)
AvantDeGlisser Cancel, Effect
End Sub
Private Sub ListBox3_MouseMove(ByVal Button As Integer, _
ByVal Shift As Integer, _
ByVal X As Single, _
ByVal Y As Single)
SourisBouge ListBox3, Button
End Sub
Private Sub ListBox3_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, _
ByVal Action As MSForms.fmAction, _
ByVal Data As MSForms.DataObject, _
ByVal X As Single, _
ByVal Y As Single, _
ByVal Effect As MSForms.ReturnEffect, _
ByVal Shift As Integer)
AvantDePoser ListBox3, Cancel, Effect, Data
End Sub
Private Sub ListBox3_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, _
ByVal Data As MSForms.DataObject, _
ByVal X As Single, _
ByVal Y As Single, _
ByVal DragState As MSForms.fmDragState, _
ByVal Effect As MSForms.ReturnEffect, _
ByVal Shift As Integer)
AvantDeGlisser Cancel, Effect
End Sub
Private Sub ListBox4_MouseMove(ByVal Button As Integer, _
ByVal Shift As Integer, _
ByVal X As Single, _
ByVal Y As Single)
SourisBouge ListBox4, Button
End Sub
Private Sub ListBox4_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, _
ByVal Action As MSForms.fmAction, _
ByVal Data As MSForms.DataObject, _
ByVal X As Single, _
ByVal Y As Single, _
ByVal Effect As MSForms.ReturnEffect, _
ByVal Shift As Integer)
AvantDePoser ListBox4, Cancel, Effect, Data
End Sub
Private Sub ListBox4_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, _
ByVal Data As MSForms.DataObject, _
ByVal X As Single, _
ByVal Y As Single, _
ByVal DragState As MSForms.fmDragState, _
ByVal Effect As MSForms.ReturnEffect, _
ByVal Shift As Integer)
AvantDeGlisser Cancel, Effect
End Sub
Private Sub ListBox5_MouseMove(ByVal Button As Integer, _
ByVal Shift As Integer, _
ByVal X As Single, _
ByVal Y As Single)
SourisBouge ListBox5, Button
End Sub
Private Sub ListBox5_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, _
ByVal Action As MSForms.fmAction, _
ByVal Data As MSForms.DataObject, _
ByVal X As Single, _
ByVal Y As Single, _
ByVal Effect As MSForms.ReturnEffect, _
ByVal Shift As Integer)
AvantDePoser ListBox5, Cancel, Effect, Data
End Sub
Private Sub ListBox5_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, _
ByVal Data As MSForms.DataObject, _
ByVal X As Single, _
ByVal Y As Single, _
ByVal DragState As MSForms.fmDragState, _
ByVal Effect As MSForms.ReturnEffect, _
ByVal Shift As Integer)
AvantDeGlisser Cancel, Effect
End Sub
Private Sub ListBox6_MouseMove(ByVal Button As Integer, _
ByVal Shift As Integer, _
ByVal X As Single, _
ByVal Y As Single)
SourisBouge ListBox6, Button
End Sub
Private Sub ListBox6_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, _
ByVal Action As MSForms.fmAction, _
ByVal Data As MSForms.DataObject, _
ByVal X As Single, _
ByVal Y As Single, _
ByVal Effect As MSForms.ReturnEffect, _
ByVal Shift As Integer)
AvantDePoser ListBox6, Cancel, Effect, Data
End Sub
Private Sub ListBox6_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, _
ByVal Data As MSForms.DataObject, _
ByVal X As Single, _
ByVal Y As Single, _
ByVal DragState As MSForms.fmDragState, _
ByVal Effect As MSForms.ReturnEffect, _
ByVal Shift As Integer)
AvantDeGlisser Cancel, Effect
End Sub
Private Sub ListBox7_MouseMove(ByVal Button As Integer, _
ByVal Shift As Integer, _
ByVal X As Single, _
ByVal Y As Single)
SourisBouge ListBox7, Button
End Sub
Private Sub ListBox7_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, _
ByVal Action As MSForms.fmAction, _
ByVal Data As MSForms.DataObject, _
ByVal X As Single, _
ByVal Y As Single, _
ByVal Effect As MSForms.ReturnEffect, _
ByVal Shift As Integer)
AvantDePoser ListBox7, Cancel, Effect, Data
End Sub
Private Sub ListBox7_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, _
ByVal Data As MSForms.DataObject, _
ByVal X As Single, _
ByVal Y As Single, _
ByVal DragState As MSForms.fmDragState, _
ByVal Effect As MSForms.ReturnEffect, _
ByVal Shift As Integer)
AvantDeGlisser Cancel, Effect
End Sub
Private Sub ListBox8_MouseMove(ByVal Button As Integer, _
ByVal Shift As Integer, _
ByVal X As Single, _
ByVal Y As Single)
SourisBouge ListBox8, Button
End Sub
Private Sub ListBox8_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, _
ByVal Action As MSForms.fmAction, _
ByVal Data As MSForms.DataObject, _
ByVal X As Single, _
ByVal Y As Single, _
ByVal Effect As MSForms.ReturnEffect, _
ByVal Shift As Integer)
AvantDePoser ListBox8, Cancel, Effect, Data
End Sub
Private Sub ListBox8_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, _
ByVal Data As MSForms.DataObject, _
ByVal X As Single, _
ByVal Y As Single, _
ByVal DragState As MSForms.fmDragState, _
ByVal Effect As MSForms.ReturnEffect, _
ByVal Shift As Integer)
AvantDeGlisser Cancel, Effect
End Sub
Private Sub ListBox9_MouseMove(ByVal Button As Integer, _
ByVal Shift As Integer, _
ByVal X As Single, _
ByVal Y As Single)
SourisBouge ListBox9, Button
End Sub
Private Sub ListBox9_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, _
ByVal Action As MSForms.fmAction, _
ByVal Data As MSForms.DataObject, _
ByVal X As Single, _
ByVal Y As Single, _
ByVal Effect As MSForms.ReturnEffect, _
ByVal Shift As Integer)
AvantDePoser ListBox9, Cancel, Effect, Data
End Sub
Private Sub ListBox9_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, _
ByVal Data As MSForms.DataObject, _
ByVal X As Single, _
ByVal Y As Single, _
ByVal DragState As MSForms.fmDragState, _
ByVal Effect As MSForms.ReturnEffect, _
ByVal Shift As Integer)
AvantDeGlisser Cancel, Effect
End Sub
Private Sub ListBox10_MouseMove(ByVal Button As Integer, _
ByVal Shift As Integer, _
ByVal X As Single, _
ByVal Y As Single)
SourisBouge ListBox10, Button
End Sub
Private Sub ListBox10_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, _
ByVal Action As MSForms.fmAction, _
ByVal Data As MSForms.DataObject, _
ByVal X As Single, _
ByVal Y As Single, _
ByVal Effect As MSForms.ReturnEffect, _
ByVal Shift As Integer)
AvantDePoser ListBox10, Cancel, Effect, Data
End Sub
Private Sub ListBox10_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, _
ByVal Data As MSForms.DataObject, _
ByVal X As Single, _
ByVal Y As Single, _
ByVal DragState As MSForms.fmDragState, _
ByVal Effect As MSForms.ReturnEffect, _
ByVal Shift As Integer)
AvantDeGlisser Cancel, Effect
End Sub
Private Sub SourisBouge(Liste As MSForms.ListBox, _
ByVal Bouton As Integer)
Dim Obj As DataObject
Dim Action As Integer
If Liste.Text = "" Then Exit Sub
If Bouton = 1 Then
Set Obj = New DataObject
With Liste: Obj.SetText .Column(0, .ListIndex) & "*" & .Column(1, .ListIndex): End With
Action = Obj.StartDrag
End If
End Sub
Private Sub AvantDePoser(Liste As MSForms.ListBox, _
Annuler As MSForms.ReturnBoolean, _
Effet As MSForms.ReturnEffect, _
Valeur As MSForms.DataObject)
Dim Pos As Integer
Annuler = True
Effet = 2
With ActiveControl.Object: .RemoveItem .ListIndex: End With
With Liste
Pos = InStr(Valeur.GetText, "*")
.AddItem Left(Valeur.GetText, Pos - 1)
.Column(1, .ListCount - 1) = Right(Valeur.GetText, Pos - 1)
End With
End Sub
Private Sub AvantDeGlisser(Annuler As MSForms.ReturnBoolean, _
Effet As MSForms.ReturnEffect)
Annuler = True
Effet = 2
End SubVoici avec un module de classe nommée Classe1. L'UserForm est nommé "UserForm1" si ce n'est pas le cas, modifier son nom dans la procédure "AvantDePoser" du module de classe à la ligne :
With [b]UserForm1[/b].ActiveControl.Object: .RemoveItem .ListIndex: End WithCode à mettre dans le module de classe :
Public WithEvents GroupeListe As MSForms.ListBox
Private Sub GroupeListe_MouseMove(ByVal Button As Integer, _
ByVal Shift As Integer, _
ByVal X As Single, _
ByVal Y As Single)
SourisBouge GroupeListe, Button
End Sub
Private Sub GroupeListe_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, _
ByVal Action As MSForms.fmAction, _
ByVal Data As MSForms.DataObject, _
ByVal X As Single, _
ByVal Y As Single, _
ByVal Effect As MSForms.ReturnEffect, _
ByVal Shift As Integer)
AvantDePoser GroupeListe, Cancel, Effect, Data
End Sub
Private Sub GroupeListe_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, _
ByVal Data As MSForms.DataObject, _
ByVal X As Single, _
ByVal Y As Single, _
ByVal DragState As MSForms.fmDragState, _
ByVal Effect As MSForms.ReturnEffect, _
ByVal Shift As Integer)
AvantDeGlisser Cancel, Effect
End Sub
Private Sub SourisBouge(Liste As MSForms.ListBox, _
ByVal Bouton As Integer)
Dim Obj As DataObject
Dim Action As Integer
If Liste.Text = "" Then Exit Sub
If Bouton = 1 Then
Set Obj = New DataObject
With Liste: Obj.SetText .Column(0, .ListIndex) & "*" & .Column(1, .ListIndex): End With
Action = Obj.StartDrag
End If
End Sub
Private Sub AvantDePoser(Liste As MSForms.ListBox, _
Annuler As MSForms.ReturnBoolean, _
Effet As MSForms.ReturnEffect, _
Valeur As MSForms.DataObject)
Dim Pos As Integer
Annuler = True
Effet = 2
With UserForm1.ActiveControl.Object: .RemoveItem .ListIndex: End With
With Liste
Pos = InStr(Valeur.GetText, "*")
.AddItem Left(Valeur.GetText, Pos - 1)
.Column(1, .ListCount - 1) = Right(Valeur.GetText, Pos - 1)
End With
End Sub
Private Sub AvantDeGlisser(Annuler As MSForms.ReturnBoolean, _
Effet As MSForms.ReturnEffect)
Annuler = True
Effet = 2
End Subcode à mettre dans le module du formulaire :
Dim Lst() As New Classe1
Private Sub UserForm_Initialize()
Dim I As Integer
For I = 1 To 10
ReDim Preserve Lst(1 To I)
Set Lst(I).GroupeListe = Me.Controls("ListBox" & I)
Lst(I).GroupeListe.ColumnCount = 2
Next I
With Lst(1).GroupeListe
For I = 1 To 10: .AddItem "Essai" & I: .Column(1, I - 1) = "Choix" & I: Next I
End With
End SubIl suffit alors d'adapter le compteur "I" au nombre de ListBox !
@Theze,
Merci beaucoup pour la proposition, mais mes 10 listboxs sont remplies de données à l'initialisation (l'affectation du personnel au moment T)
Et depuis chacune de ces listboxs, je dois pouvoir balader un item dans n'importe quelle autre, ça nécessite peut-être un code un peu lourd...
Je ne pense pas qu'on puisse arriver à ce résultat avec ta solution ?
Merci en tout cas de te pencher sur mon cas
Bonne soirée !
@theze
Ben finalement ça me plait bien !
Désolé de n'avoir pas regardé en profondeur, mais ça solutionne mon problème !
Merci beaucoup
Bonjour,
ça ne change absolument rien que tes ListBox soient ou non remplies !
C'est dans Initialize que tu remplis tes différentes ListBox :
Dim Lst() As New Classe1
Private Sub UserForm_Initialize()
Dim I As Integer
Dim J As Integer
'remplissage des ListBox avec les valeurs situées dans les cellules
For I = 1 To 10: For J = 1 To 20
Me.Controls("ListBox" & I).AddItem Cells(J, I).Value
Next J, I
'stockage dans le tableau
For I = 1 To 10
ReDim Preserve Lst(1 To I): Set Lst(I).GroupeListe = Me.Controls("ListBox" & I)
Next I
End SubBonjour,
Je reviens un peu sur ma dernière réponse, j'ai modifié le code de la classe afin qu'elle soit au mieux encapsulée donc, l'UserForm est passé à la propriété "Formulaire" de la classe afin qu'elle n'est pas à faire cet appel externe et j'ai aussi modifié les procédures évènementielles afin de prendre en compte le nombre de colonnes de façon dynamique de chaque ListBox (quel que soit le nombre de colonnes, toutes les valeurs seront transférées d'une liste à l'autre) :
Code dans le module de l'UserForm :
Dim Lst() As New Classe1
Private Sub UserForm_Initialize()
Dim I As Integer
For I = 1 To 2
ReDim Preserve Lst(1 To I)
Set Lst(I).GroupeListe = Me.Controls("ListBox" & I) 'instancie la classe
Lst(I).GroupeListe.ColumnCount = 5 'nombre de colonnes
'passe le formulaire à la classe afin qu'elle n'ai aucun appel extérieur à faire (encapsulage)
Set Lst(I).Formulaire = Me
Next I
'rempli la 1ère liste (elles pourraient être toutes remplies ici)
With Lst(1).GroupeListe
For I = 1 To 10
.AddItem "Nom " & I
.Column(1, I - 1) = "Prénom " & I
.Column(2, I - 1) = "Adresse " & I
.Column(3, I - 1) = "CP " & I
.Column(4, I - 1) = "Ville " & I
Next I
End With
End SubCode dans la classe nommée "Classe1" :
Public WithEvents GroupeListe As MSForms.ListBox
Dim Form As MSForms.UserForm
Private Sub GroupeListe_MouseMove(ByVal Button As Integer, _
ByVal Shift As Integer, _
ByVal X As Single, _
ByVal Y As Single)
Dim Obj As DataObject
Dim Action As Integer
Dim Chaine As String
Dim I As Integer
If GroupeListe.Text = "" Then Exit Sub
If Button = 1 Then
'fonction du nombre de colonnes
With GroupeListe: For I = 0 To .ColumnCount - 1: Chaine = Chaine & .Column(I, .ListIndex) & "*": Next I: End With
Set Obj = New DataObject
Obj.SetText Chaine
Action = Obj.StartDrag
End If
End Sub
Private Sub GroupeListe_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, _
ByVal Action As MSForms.fmAction, _
ByVal Data As MSForms.DataObject, _
ByVal X As Single, _
ByVal Y As Single, _
ByVal Effect As MSForms.ReturnEffect, _
ByVal Shift As Integer)
Dim Tbl
Dim Pos As Integer
Dim I As Integer
Cancel = True
Effect = 2
With Form.ActiveControl.Object: .RemoveItem .ListIndex: End With
Tbl = Split(Data.GetText, "*")
With GroupeListe
'fonction du nombre de colonnes
.AddItem Tbl(0)
For I = 1 To UBound(Tbl): .Column(I, .ListCount - 1) = Tbl(I): Next I
End With
End Sub
Private Sub GroupeListe_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, _
ByVal Data As MSForms.DataObject, _
ByVal X As Single, _
ByVal Y As Single, _
ByVal DragState As MSForms.fmDragState, _
ByVal Effect As MSForms.ReturnEffect, _
ByVal Shift As Integer)
Cancel = True
Effect = 2
End Sub
Property Set Formulaire(Usf As MSForms.UserForm)
Set Form = Usf
End PropertyBonjour Theze,
Ta première solution fonctionne parfaitement après l'avoir adaptée à mon cas.
Est-il bien nécessaire de la modifier par celle-ci ? Quel est le gain ? La rapidité de traitement ?
Et puisque tu es là :p .... :
Mes 10 boxs sont remplies en fonction du poste trouvé dans le tableau "personnel".
Comment faire, après avoir baladé les noms de l'une à l'autre, pour mettre à jour les modifications dans le tableau ?
Merci à toi et bon dimanche !
Re,
L'utilisation d'un module de classe permet de réduire et simplifier le code, il suffit de voir le nombre de lignes de code entre mon premier post et le dernier !
Le module de classe gère ici seulement les trois événements des ListBox ce qui évite de les réécrire (10 fois dans ton cas).
Le remplissage de chaque ListBox peut se faire avant d'instancier et pour la récupération des données quelles contiennent, ça ne change rien à ton code.
Ici, un bouton inscrit dans les colonnes de A à D les valeurs de chaque ListBox (ici, 4 avec seulement une colonne) après déplacement des différentes valeurs entre les différentes Listox. Les valeurs qui ont alimentées les ListBox au lancement de la Form sont issues de ces mêmes colonnes :
Dim Lst() As New Classe1
Private Sub CommandButton1_Click()
Dim I As Integer
Columns("A:D").Cells.Clear
With ListBox1: For I = 1 To .ListCount - 1: Cells(I, 1).Value = .List(I - 1): Next I: End With
With ListBox2: For I = 1 To .ListCount - 1: Cells(I, 2).Value = .List(I - 1): Next I: End With
With ListBox3: For I = 1 To .ListCount - 1: Cells(I, 3).Value = .List(I - 1): Next I: End With
With ListBox4: For I = 1 To .ListCount - 1: Cells(I, 4).Value = .List(I - 1): Next I: End With
End Sub
Private Sub UserForm_Initialize()
Dim Plage As Range
Dim I As Integer
With ActiveSheet: Set Plage = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)): End With
With ListBox1: For I = 1 To Plage.Count: .AddItem Plage(I).Value: Next I: End With
With ActiveSheet: Set Plage = .Range(.Cells(1, 2), .Cells(.Rows.Count, 2).End(xlUp)): End With
With ListBox2: For I = 1 To Plage.Count: .AddItem Plage(I).Value: Next I: End With
With ActiveSheet: Set Plage = .Range(.Cells(1, 3), .Cells(.Rows.Count, 3).End(xlUp)): End With
With ListBox3: For I = 1 To Plage.Count: .AddItem Plage(I).Value: Next I: End With
With ActiveSheet: Set Plage = .Range(.Cells(1, 4), .Cells(.Rows.Count, 4).End(xlUp)): End With
With ListBox4: For I = 1 To Plage.Count: .AddItem Plage(I).Value: Next I: End With
For I = 1 To 4
ReDim Preserve Lst(1 To I)
Set Lst(I).GroupeListe = Me.Controls("ListBox" & I) 'instancie la classe
Lst(I).GroupeListe.ColumnCount = 1 'nombre de colonnes
'passe le formulaire à la classe afin qu'elle n'ai aucun appel extérieur à faire (encapsulage)
Set Lst(I).Formulaire = Me
Next I
End Sub