Discussion :

[veryred]

Bonjour

J'essaie de coder un Drag and Drop dans un UserForm sous Excel. J'ai des sources récupérées de droite et de gauche, mais elles ne sont pas applicables directement. Mon principal problème vient du fait que les seuls événements disponibles sont OLEDrag, OLEDragDrop, etc .. Hors ces évènements ne sont jamais utilisés dans les sources que j'ai trouvé !
Si quelqu'un à un code simple qui marche ou une idée, je suis preneur.

[SilkyRoad]

bonsoir

j'espère que cet exemple pourra t'aider
(l'userform contient deux controles: ListView1 et ListView2)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
Option Explicit
 
Private objDrag As Object
Private boolDrag As Boolean
 
 
Private Sub UserForm_Initialize()
 
    '----- remplissage ListView------------------------
    With ListView1
        'Définit le nombre de colonnes et Entêtes
        With .ColumnHeaders
            'Supprime les anciens entêtes
            .Clear
            'Ajoute 1 colonne en spécifiant le nom de l'entête
            'et la largeur de la colonne
            .Add , , "Nom", 80
        End With
 
        'Remplissage de la 1ere colonne (création de 3 lignes)
        With .ListItems
           .Add , , "Riri"
           .Add , , "Fifi"
           .Add , , "Loulou"
         End With
 
        'Spécifie l'affichage
        .View = lvwReport
        '.OLEDragMode = ccOLEDragAutomatic
    End With
    '--------------------------------------------------
 
 
    With ListView2.ColumnHeaders
        'Supprime les anciens entêtes
        .Clear
        'Ajoute 1 colonne en spécifiant le nom de l'entête
        'et la largeur de la colonne
        .Add , , "Nom", 80
    End With
 
    ListView2.View = lvwReport
    'ListView2.OLEDragMode = ccOLEDragAutomatic
 
End Sub
 
 
Private Sub ListView1_MouseDown(ByVal Button As Integer, _
    ByVal Shift As Integer, ByVal x As stdole.OLE_XPOS_PIXELS, _
    ByVal y As stdole.OLE_YPOS_PIXELS)
 
    'Si le bouton de gauche est cliqué
    If Button = 1 Then boolDrag = True
End Sub
 
 
Private Sub ListView1_MouseMove(ByVal Button As Integer, _
    ByVal Shift As Integer, ByVal x As stdole.OLE_XPOS_PIXELS, _
    ByVal y As stdole.OLE_YPOS_PIXELS)
 
     If Button = 1 And boolDrag Then
          ListView1.OLEDrag
          ListView1.MousePointer = ccSize
          Set objDrag = ListView1.SelectedItem
     End If
 
End Sub
 
 
Private Sub ListView2_MouseMove(ByVal Button As Integer, _
    ByVal Shift As Integer, ByVal x As stdole.OLE_XPOS_PIXELS, _
    ByVal y As stdole.OLE_YPOS_PIXELS)
 
    If boolDrag And Not objDrag Is Nothing Then
        'Ajoute un élément de ListView1 vers ListView2
        ListView2.ListItems.Add , , objDrag.Text
        boolDrag = False
 
        ListView1.MousePointer = ccDefault
        'Supprime l'élément dans la ListView1
        ListView1.ListItems.Remove (ListView1.SelectedItem.Index)
 
        'Désélectionne l'élément dans la listView1
       If ListView1.ListItems.Count > 0 Then
            ListView1.ListItems(1).Selected = False
            Set ListView1.SelectedItem = Nothing
       End If
    End If
End Sub

bonne soirée
michel

[Fouinard]

Salut

Voila ce que j'utilise pour faire un drag & drop à l'intérieur d'une même listview pour trier les éléments à la souris

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
' --------------------------------------------------------------
' Permet de convertir les pixels en twips
' nécessaire pour utiliser "hittest"
 
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
 
Private Const HWND_DESKTOP As Long = 0
Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90
 
Function TwipsPerPixelX() As Single
Dim lngDC As Long
    lngDC = GetDC(HWND_DESKTOP)
    TwipsPerPixelX = 1440& / GetDeviceCaps(lngDC, LOGPIXELSX)
    ReleaseDC HWND_DESKTOP, lngDC
End Function
 
Function TwipsPerPixelY() As Single
Dim lngDC As Long
    lngDC = GetDC(HWND_DESKTOP)
    TwipsPerPixelY = 1440& / GetDeviceCaps(lngDC, LOGPIXELSY)
    ReleaseDC HWND_DESKTOP, lngDC
End Function
 
' conversion pixels -> twips
Public Function TwipsX(ByVal NbPixels As Single) As Single
    TwipsX = NbPixels * (TwipsPerPixelX + 5)
End Function
 
Public Function TwipsY(ByVal NbPixels As Single) As Single
    TwipsY = NbPixels * (TwipsPerPixelY + 5)
End Function
 
' --------------------------------------------------------------
 
Private Sub listviewServices_OLEStartDrag(Data As MSComctlLib.DataObject, AllowedEffects As Long)
    'Debug.Print ("drag start")
    Data.SetData (listviewServices.SelectedItem.Index)
    listviewServices.ListItems.Add , , "" ' ajoute un nouvel élément à la listview qui permet
                                          ' de déplacer les élément en bas de la liste
    dragEnCours = True
    listviewServices.Sorted = False   ' désactive le tri automatique
End Sub
 
Private Sub listviewServices_OLEDragOver(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single, State As Integer)
    'Debug.Print ("drag over")
 
    On Error GoTo erreur
    If dragEnCours Then
	' les fonctions Twipsx et Twipsy permettent de convertir les pixels en twips
	' drophightlight permet de mettre en couleur l'item sur lequel se trouve la souris
	' hittest permet de retourner l'item sur lequel on se trouve
        Set listviewServices.DropHighlight = listviewServices.HitTest(TwipsX(x), TwipsY(y))
        listviewServices.HitTest(TwipsX(x), TwipsY(y)).EnsureVisible
    End If
 
    Exit Sub
erreur:
    ' la ligne de la listview n'existe pas
End Sub
 
Private Sub listviewServices_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
    'Debug.Print ("drag drop")
    dragEnCours = False
 
    On Error GoTo erreur
 
    Dim indexDrag, indexDrop As Integer
    indexDrag = CInt(Data.GetData(1))	' index de l'item sur lequel on a cliqué au départ
    indexDrop = listviewServices.DropHighlight.Index   ' index de l'item sur lequel on drop
 
    If indexDrag <> indexDrop Then ' si les deux index sont différents
	' on créé un nouvel item (copie de celui qu'on drag)
        listviewServices.ListItems.Add indexDrop, , listviewServices.ListItems.Item(indexDrag).Text
 
	' permet d'ajouter les subitems et de supprimer l'item de départ
        If indexDrag > indexDrop Then
            For i = 1 To 6
                listviewServices.ListItems.Item(indexDrop).ListSubItems.Add , , _
                        listviewServices.ListItems.Item(indexDrag + 1).ListSubItems.Item(i).Text
            Next
 
            listviewServices.ListItems.Remove (indexDrag + 1)
            listviewServices.ListItems.Item(indexDrop).Selected = True
        Else
            For i = 1 To 6
                listviewServices.ListItems.Item(indexDrop).ListSubItems.Add , , _
                        listviewServices.ListItems.Item(indexDrag).ListSubItems.Item(i).Text
            Next
 
            listviewServices.ListItems.Remove (indexDrag)
            listviewServices.ListItems.Item(indexDrop - 1).Selected = True
        End If
    End If
 
erreur:
 
End Sub
 
Private Sub listviewServices_OLECompleteDrag(Effect As Long)
    'Debug.Print ("drag complete")
 
    Set listviewServices.DropHighlight = Nothing
 
    ' on supprime l'item qu'on a créé au début du drag & drop qui permettait de déplacer l'item tout
    ' en bas de la listview
    listviewServices.ListItems.Remove (listviewServices.ListItems.Count)
 
End Sub

J'espère que ça pourra t'aider

[paoloadv]

Salut
Voila ce que j'utilise pour faire un drag & drop à l'intérieur d'une même listview pour trier les éléments à la souris

Bonjour,
Ce code ne marche pas du tout chez moi (VBA Excel 2010, Environnement MSO 2010). A la tentative de déplacement d'une ligne de la listView par un drag & drop, c'est une infinité de lignes vides qui sont créées!
Dommage.

[paoloadv]

bonsoir
j'espère que cet exemple pourra t'aider
(l'userform contient deux controles: ListView1 et ListView2)
l

Bonjour Michel,
Merci pour ton code, il m'a servi de base pour compléter le mien. J'ai ajouté la gestion du traitement de la ligne à transférer d'une liste à l'autre, comme cela se fait en vrai drag & drop: la souris change de forme tant que l'on a cliqué dessus sur une ligne d'une liste. Si l'on maintient le clic souris enfoncé en la déplaçant vers l'autre liste, et qu'on la relache sur la liste cible, la ligne y est déposée. Sinon l'opération est annulée et la souris reprend sa forme (parfois il y a un petit laps d'attente...).
Par contre, je trouve cela plus complexe, le Drag & drop au sein d'une même listView avec les évènements OLEDragDrop... Cela implique qu'il faut prendre en compte la position initiale de la (des) ligne(s) sélectionnée(s), et qu'au cours du déplacement de la souris (touche gauche maintenue enfoncée), on repère la position possible du future dépos dans la même listView. On pourrait imaginer que ce traitement soit le même, que ce soit pour une même listView ou d'une liste à une autre, à condition de choisir pour mode de déplacement que les lignes sélectionnées soient déplacées à la position de la ligne pointée par la souris dans la liste cible. A voir.. J'y réfléchis. En attendant, voici ma version de gestion entre 2 listViews...
A bientôt!
Paolo
ListView_Paul_v6.zip