[XL-2003] Drag and drop en VBA

Drag and drop en VBA

Bonjour tout le monde,

Je génère dans un userform des labels un peu à la manière de postits.

J'aimerais permettre à l'utilisateur de les déplacer par un glisser-déplacer mais je n'arrive malheureusement pas à ça avec les outils MouseUp, MouseDown et MouseMove.

Pour l'instant mon code ressemble à ceci pour un de mes labels :
Code:

1 2 3 4 5 6 Private Sub label1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) Planning.Label1.Caption = X & ":" & Y Label1.Left = X Label1.Top = Y End Sub
Existe-t-il une fonction Drag and Drop sur excel/vba ?

Peut-on combiner différement ?

Merci d'avance

bjr,

le X et Y sont des coordonnées dans le label
il faut donc conserver les coordonnées lors du clic (MouseDown) pour trouver le Delta lors du déplacement (MouseUp)

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
 
Private gClicX As Single, gClicY As Single
 
Private Sub Label1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button = vbKeyLButton Then
    gClicX = X
    gClicY = Y
End If
End Sub
 
Private Sub Label1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button = vbKeyLButton Then
    Label1.Left = Label1.Left - (gClicX - X)
    Label1.Top = Label1.Top - (gClicY - Y)
End If
End Sub

Si tu as beaucoup d'étiquettes, ça devient compliqué, il faut tout copier-coller autant de fois qu'il y a d'étiquettes.
Il est alors intéressant de faire un module de classe.

Insertion => Module de classe
Ajouter le code ci-dessous et nommer le module clDragLabel.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
 
Option Explicit
 
' Position lors du clic
Private gClicX As Single, gClicY As Single
' Etiquette qui génère les événement
Private WithEvents goLabel As MSForms.Label
' Formulaire contenant le label et les procédures DragMouseDown / DragMouseMove / DragMouseUp
Private goUserForm As Object
 
' Propriété pour définir l'étiquette
Public Property Let Label(pLabel As MSForms.Label)
    Set goLabel = pLabel
End Property
 
' Propriété pour définir le formulaire
Public Property Let UserForm(pUserForm As Object)
    Set goUserForm = pUserForm
End Property
 
' Sur souris appuyée
Private Sub goLabel_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
' Si bouton gauche
If Button = vbKeyLButton Then
    ' Conserve la position du clic
    gClicX = X
    gClicY = Y
    ' Appelle la procédure DragMouseDown du formulaire
    CallByName goUserForm, "DragMouseDown", VbMethod, goLabel
End If
End Sub
 
' Sur souris déplacée
Private Sub goLabel_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
' Si bouton gauche
If Button = vbKeyLButton Then
    ' Déplace l'étiquette en fonction de sa position courante, de la position du clic et de la position
    '   de la souris déplacée sur l'étiquette
    goLabel.Left = goLabel.Left - (gClicX - X)
    goLabel.Top = goLabel.Top - (gClicY - Y)
    ' Appelle la procédure DragMouseMove du formulaire
    CallByName goUserForm, "DragMouseMove", VbMethod, goLabel
End If
End Sub
 
' Sur souris relâchée
Private Sub goLabel_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
' Si bouton gauche
If Button = vbKeyLButton Then
    ' Appelle la procédure DragMouseUp du formulaire
    CallByName goUserForm, "DragMouseUp", VbMethod, goLabel
End If
End Sub

Le code du formulaire :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
 
Option Explicit
 
' Collection d'objets clDragLabel
' Chaque étiquette déplaçable sera ajouté dans un objet clDragLabel
' Chacun de ces objets est ajouté à la collection pour qu'il ne soient pas détruits
Private gLabels As Collection
 
' Initialisation du formulaire
Private Sub UserForm_Initialize()
' Initialise la collection
Set gLabels = New Collection
' Ajoute les étiquette à déplacer
AddDragLabel Me.Label1
AddDragLabel Me.Label2
End Sub
 
' Sur souris appuyée sur l'étiquette pLabel
Public Sub DragMouseDown(pLabel As MSForms.Label)
pLabel.Caption = "MouseDown"
End Sub
 
' Sur souris déplacée sur l'étiquette pLabel
Public Sub DragMouseMove(pLabel As MSForms.Label)
pLabel.Caption = "MouseMove"
End Sub
 
' Sur souris relâchée sur l'étiquette pLabel
Public Sub DragMouseUp(pLabel As MSForms.Label)
pLabel.Caption = "MouseUp"
End Sub
 
' Fonction privée utilisée pour créer un objet clDragLabel
'    et l'ajouter à la collection gLabels
Private Sub AddDragLabel(pLabel As MSForms.Label)
Dim loLabel As clDragLabel
' Nouvel objet clDragLabel
Set loLabel = New clDragLabel
' Définit l'étiquette
loLabel.Label = pLabel
' Définit le formulaire (pour recevoir les appels aux procédures DragMouve*)
loLabel.UserForm = Me
' Ajoute l'objet à la collection
' Ainsi l'objet n'est pas détruit lorsqu'on sort de cette procédure
gLabels.Add loLabel
End Sub

Chaque étiquette déplaçable est définie dans UserForm_Initialize en utilisant la petite procédure AddDragLabel.

Les procédures DragMouseDown, DragMouseMove et DragMouseUp sont appelées respectivement sur souris appuyée, déplacée et relachée sur une étiquette.
L'étiquette en déplacement est dans le paramètre pLabel.

Note : le code donné ne fonctionne que pour des étiquettes (label).
Pour un autre type de contrôle, il faut modifier le code (c'est faisable mais ça complique beaucoup le module).
C'est à cause du WithEvents qui ne permet pas de définir un type de données "Control" qui pourrait fonctionner avec tous les contrôles.

Bon courage.

Merci beaucoup,

Je dois dire que je suis impressionné par la rapidité et la clarté de la réponse.

En tout cas ça marche trés bien.

Je crée un certain nombre de Label en passant par une boucle (postit1, postit2...).

J'obtiens donc à un moment dans ma création de label une variable "a" donnant le numéro de mon label à créer.

Comment corriger

Citation:

AddDragLabel Me.Label1

?

AddDragLabel Me.Postit & a ?

Merci d'avance

avec la collection contrôle peut-être :

Code:

Me.Controls("NomDuContrôle")