Glisser-déposer entre deux zones de listes [Sources]

**Arkham46** · 05/03/2009, 23h31

Remarque préalable : J'utilise pour cette source les fonctions d'accessibilité, ce sont les fonctions accHitTest, accLocation qui sont masquées et non documentées, donc pas de garantie de fonctionnement pour les prochaines versions par exemple.

Un exemple de glisser-déposer entre deux zones de liste dans un formulaire Access :
ftp://ftp-developpez.com/arkham46/fichiers/dragdrop.zip
Mirroir HTTP
La base de données est au format 2000, mais il faut pour cette version retirer les appels à AddItem et RemoveItem qui ne fonctionnent pas avec Access 2000 (ça ne devrait pas empêcher le reste de tourner).

Pour créer le formulaire qui gère l'encadrement de l'élément survolé :
- Créez un nouveau formulaire FormDrag
- fen indépendante = oui
- Style bordure = aucun
- Afficher sélecteur = non
- Mettez en couleur de fond la couleur qui encadrera l'élément glissé
- Collez-y ce code :

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
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
 
'***************************************************************************************
'*              FORMULAIRE POUR DRAG&DROP
'***************************************************************************************
Option Compare Database
Option Explicit
 
'**************************************
' APIs
'**************************************
Private Declare Sub ReleaseCapture Lib "user32" ()
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
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 Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As PointAPI) As Long
Private Declare Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" _
                                       (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias _
                                       "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, _
                                                         ByVal dwNewLong As Long) As Long
Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crey As Byte, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Private Declare Sub SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, _
                                               ByVal X As Long, ByVal Y As Long, ByVal cx As Long, _
                                               ByVal cy As Long, ByVal wFlags As Long)
'**************************************
' Types
'**************************************
Private Type PointAPI
    X As Long
    Y As Long
End Type
'**************************************
' Constantes
'**************************************
Private Const RGN_DIFF = 4
Private Const LOGPIXELSY = 90
Private Const LOGPIXELSX = 88
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_SHOWWINDOW = &H40
Private Const SWP_HIDEWINDOW = &H80
Private Const SWP_FOCUSWINDOW = 0
Private Const SWP_NOOWNERZORDER = &H200
Private Const SWP_NOREDRAW = &H8
Private Const WS_EX_TRANSPARENT = &H20&
Private Const GWL_EXSTYLE = (-20)
Private Const WS_EX_LAYERED = &H80000
Private Const LWA_ALPHA = &H2&
'**************************************
' Variables
'**************************************
Private gDragIndex As Long
Private gDraggingIndex As Long
Private gObjDrag As Access.ListBox
Private gObjDragging As Access.ListBox
Private gDragX As Long
Private gDragY As Long
 
Private WithEvents gListe1 As Access.ListBox
Private WithEvents gListe2 As Access.ListBox
'**************************************
' Evénements
'**************************************
Public Event BeginDrag(pListeDrag As Access.ListBox, pIndexDrag As Long)
Public Event IsDragging(pListeDrag As Access.ListBox, pIndexDrag As Long, pListeDragging As Access.ListBox, pIndexDragging As Long)
Public Event Drop(pListeDrag As Access.ListBox, pIndexDrag As Long, pListeDrop As Access.ListBox, pIndexDrop As Long)
Public Event EndDrag(pListeDrag As Access.ListBox, pIndexDrag As Long)
 
'---------------------------------------------------------------------------------------
' Initialise le formulaire
'---------------------------------------------------------------------------------------
' pListe1 : première liste
' pListe2 : deuxième liste
'---------------------------------------------------------------------------------------
Public Sub Initialize(pListe1 As Access.ListBox, pListe2 As Access.ListBox)
Set gListe1 = pListe1
gListe1.OnMouseDown = Me.OnLoad
gListe1.OnMouseMove = Me.OnLoad
gListe1.OnMouseUp = Me.OnLoad
Set gListe2 = pListe2
gListe2.OnMouseDown = Me.OnLoad
gListe2.OnMouseMove = Me.OnLoad
gListe2.OnMouseUp = Me.OnLoad
End Sub
 
'---------------------------------------------------------------------------------------
' Libère les variables du formulaire
'---------------------------------------------------------------------------------------
Private Sub ReleaseForm()
    On Error GoTo Gestion_Erreurs
    gDragIndex = -1
    gDraggingIndex = -1
    Set gObjDrag = Nothing
    Set gObjDragging = Nothing
    Me.Visible = False
    Exit Sub
Gestion_Erreurs:
    MsgBox "Erreur n°" & Err.Number & ", " & Err.Description & ", dans la procédure ReleaseForm du module Form_FormCadre"
End Sub
 
'---------------------------------------------------------------------------------------
' Positionne le formulaire sur une liste
'---------------------------------------------------------------------------------------
' pObj : Contrôle liste access
'---------------------------------------------------------------------------------------
Private Sub SetObject(pObj As Access.ListBox)
    Dim lLeft As Long, lTop As Long, lWidth As Long
    Static sHeight As Long
    Dim lLeftList As Long, lTopList As Long, lWidthList As Long, lHeightList As Long
    Dim lindex As Variant
    Dim lPt As PointAPI
    Dim lRgn1 As Long, lRgn2 As Long, lRgnVisible As Long
    On Error GoTo Gestion_Erreurs
    lindex = GetMouseIndex(pObj)
    GetCursorPos lPt
    Call pObj.accLocation(lLeftList, lTopList, lWidthList, lHeightList, ByVal 0&)
    If lindex <> -1 And lindex <= pObj.ListCount - 1 Then
        Call pObj.accLocation(lLeft, lTop, lWidth, sHeight, lindex + 1)
        Me.InsideWidth = PixelToPointsX(lWidthList)
        Me.InsideHeight = PixelToPointsY(sHeight)
 
        SetWindowPos Me.hwnd, HWND_TOPMOST, lLeft, lTop, lWidthList, sHeight, SWP_SHOWWINDOW Or SWP_NOACTIVATE
        lRgn1 = CreateRectRgn(0, 0, lWidthList - 1, sHeight - 1)
        lRgn2 = CreateRectRgn(2, 2, lWidthList - 3, sHeight - 3)
        lRgnVisible = CreateRectRgn(0, 0, 1, 1)
        Call CombineRgn(lRgnVisible, lRgn1, lRgn2, RGN_DIFF)
        DeleteObject lRgn1
        DeleteObject lRgn2
        SetWindowRgn Me.hwnd, lRgnVisible, True
        DeleteObject lRgnVisible
    Else
        SetWindowPos Me.hwnd, HWND_TOPMOST, lLeftList, lPt.Y - sHeight / 2, 0, 0, SWP_NOSIZE Or SWP_SHOWWINDOW Or SWP_NOACTIVATE
    End If
    Exit Sub
Gestion_Erreurs:
    MsgBox "Erreur n°" & Err.Number & ", " & Err.Description & ", dans la procédure SetObject du module Form_FormCadre"
End Sub
 
'---------------------------------------------------------------------------------------
' Chargement du formulaire
'---------------------------------------------------------------------------------------
Private Sub Form_Load()
    On Error GoTo Gestion_Erreurs
    gDragIndex = -1
    gDraggingIndex = -1
    Me.Modal = False
    SetWindowLong Me.hwnd, GWL_EXSTYLE, GetWindowLong(Me.hwnd, GWL_EXSTYLE) Or WS_EX_TRANSPARENT Or WS_EX_LAYERED
    SetLayeredWindowAttributes Me.hwnd, 0, 255, LWA_ALPHA
    Exit Sub
Gestion_Erreurs:
    MsgBox "Erreur n°" & Err.Number & ", " & Err.Description & ", dans la procédure Form_Load du module Form_FormCadre"
End Sub
 
'---------------------------------------------------------------------------------------
' Minuterie du formulaire
'---------------------------------------------------------------------------------------
Private Sub Form_Timer()
    On Error GoTo Gestion_Erreurs
    If GetAsyncKeyState(vbKeyLButton) = 0 Then
        ReleaseForm
    End If
    Exit Sub
Gestion_Erreurs:
    MsgBox "Erreur n°" & Err.Number & ", " & Err.Description & ", dans la procédure Form_Timer du module Form_FormCadre"
End Sub
 
'---------------------------------------------------------------------------------------
' Déchargement du formulaire
'---------------------------------------------------------------------------------------
Private Sub Form_Unload(Cancel As Integer)
SetWindowRgn Me.hwnd, ByVal 0&, True
End Sub
 
'---------------------------------------------------------------------------------------
' Souris appuyée sur une des listes
'---------------------------------------------------------------------------------------
Private Sub gListe_MouseDown(pListe1 As Access.ListBox, pListe2 As Access.ListBox, Button As Integer, Shift As Integer, X As Single, Y As Single)
    On Error GoTo Gestion_Erreurs
    If Button = vbKeyLButton Then
        gDragY = Y
        gDragX = X
    End If
    Exit Sub
Gestion_Erreurs:
    MsgBox "Erreur n°" & Err.Number & ", " & Err.Description & ", dans la procédure gListe_MouseDown du module Form_FormDrag"
End Sub
 
'---------------------------------------------------------------------------------------
' Souris déplacée sur une des listes
'---------------------------------------------------------------------------------------
Private Sub gListe_MouseMove(pListe1 As Access.ListBox, pListe2 As Access.ListBox, Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim ldrag As Long
    On Error GoTo Gestion_Erreurs
    If Button = vbKeyLButton Then
            ldrag = GetMouseIndex(pListe1)
            If ldrag <> -1 Then
                If gDragIndex = -1 And gObjDrag Is Nothing Then
                    If ldrag <= pListe1.ListCount - 1 Then
                        ReleaseCapture
                        gDragIndex = ldrag
                        gDraggingIndex = ldrag
                        Set gObjDrag = pListe1
                        Set gObjDragging = pListe1
                        SetObject pListe1
                        RaiseEvent BeginDrag(pListe1, ldrag)
                    End If
                Else
                    If gDraggingIndex <> ldrag Or Not pListe1 Is gObjDragging Then
                        SetObject pListe1
                        RaiseEvent IsDragging(gObjDrag, gDragIndex, pListe1, ldrag)
                        gDraggingIndex = ldrag
                        Set gObjDragging = pListe1
                    ElseIf ldrag > gObjDragging.ListCount - 1 Then
                        SetObject pListe1
                        Set gObjDragging = pListe1
                    End If
                End If
            End If
    End If
    Exit Sub
Gestion_Erreurs:
    MsgBox "Erreur n°" & Err.Number & ", " & Err.Description & ", dans la procédure gListe_MouseMove du module Form_FormDrag"
End Sub
 
'---------------------------------------------------------------------------------------
' Souris relâchée sur une des listes
'---------------------------------------------------------------------------------------
Private Sub gListe_MouseUp(pListe1 As Access.ListBox, pListe2 As Access.ListBox, Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim lindex As Long
    On Error GoTo Gestion_Erreurs
    gDragY = 0
    If gDragIndex = -1 Then Exit Sub
    lindex = -1
    lindex = GetMouseIndex(pListe1)
    If lindex <> -1 Then
        RaiseEvent Drop(gObjDrag, gDragIndex, pListe1, lindex)
    End If
    RaiseEvent EndDrag(gObjDrag, gDragIndex)
    ReleaseForm
    Exit Sub
Gestion_Erreurs:
    MsgBox "Erreur n°" & Err.Number & ", " & Err.Description & ", dans la procédure gListe_MouseUp du module Form_FormDrag"
End Sub
 
'---------------------------------------------------------------------------------------
' Souris appuyée sur la première liste
'---------------------------------------------------------------------------------------
Private Sub gListe1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    On Error GoTo Gestion_Erreurs
    gListe_MouseDown gListe1, gListe2, Button, Shift, X, Y
Exit Sub
Gestion_Erreurs:
    MsgBox "Erreur n°" & Err.Number & ", " & Err.Description & ", dans la procédure gListe1_MouseDown du module Form_FormDrag"
End Sub
 
'---------------------------------------------------------------------------------------
' Souris déplacée sur la première liste
'---------------------------------------------------------------------------------------
Private Sub gListe1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    On Error GoTo Gestion_Erreurs
    gListe_MouseMove gListe1, gListe2, Button, Shift, X, Y
    Exit Sub
Gestion_Erreurs:
    MsgBox "Erreur n°" & Err.Number & ", " & Err.Description & ", dans la procédure gListe1_MouseMove du module Form_FormDrag"
End Sub
 
'---------------------------------------------------------------------------------------
' Souris relâchée sur la première liste
'---------------------------------------------------------------------------------------
Private Sub gListe1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    On Error GoTo Gestion_Erreurs
    gListe_MouseUp gListe1, gListe2, Button, Shift, X, Y
    Exit Sub
Gestion_Erreurs:
    MsgBox "Erreur n°" & Err.Number & ", " & Err.Description & ", dans la procédure gListe1_MouseUp du module Form_FormDrag"
End Sub
 
'---------------------------------------------------------------------------------------
' Souris appuyée sur la deuxième liste
'---------------------------------------------------------------------------------------
Private Sub gListe2_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    On Error GoTo Gestion_Erreurs
    gListe_MouseDown gListe2, gListe1, Button, Shift, X, Y
Exit Sub
Gestion_Erreurs:
    MsgBox "Erreur n°" & Err.Number & ", " & Err.Description & ", dans la procédure gListe2_MouseDown du module Form_FormDrag"
End Sub
 
'---------------------------------------------------------------------------------------
' Souris déplacée sur la deuxième liste
'---------------------------------------------------------------------------------------
Private Sub gListe2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    On Error GoTo Gestion_Erreurs
    gListe_MouseMove gListe2, gListe1, Button, Shift, X, Y
    Exit Sub
Gestion_Erreurs:
    MsgBox "Erreur n°" & Err.Number & ", " & Err.Description & ", dans la procédure gListe2_MouseMove du module Form_FormDrag"
End Sub
 
'---------------------------------------------------------------------------------------
' Souris relâchée sur la deuxième liste
'---------------------------------------------------------------------------------------
Private Sub gListe2_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    On Error GoTo Gestion_Erreurs
    gListe_MouseUp gListe2, gListe1, Button, Shift, X, Y
    Exit Sub
Gestion_Erreurs:
    MsgBox "Erreur n°" & Err.Number & ", " & Err.Description & ", dans la procédure gListe2_MouseUp du module Form_FormDrag"
End Sub
 
'---------------------------------------------------------------------------------------
' Converti les Pixels en Points sur l'axe horizontal
'---------------------------------------------------------------------------------------
' pPixelsX : Valeur a convertir en Pixels
' Renvoie la valeur convertie en Points
'---------------------------------------------------------------------------------------
Private Function PixelToPointsX(pPixelsX As Long) As Long
    Static Mult As Single
    Dim hdc As Long
    If Mult = 0 Then
        hdc = GetDC(0)
        Mult = 1440 / GetDeviceCaps(hdc, LOGPIXELSX)
        ReleaseDC 0, hdc
    End If
    PixelToPointsX = pPixelsX * Mult
End Function
 
'---------------------------------------------------------------------------------------
' Converti les Pixels en Points sur l'axe vertical
'---------------------------------------------------------------------------------------
' pPixelsY : Valeur a convertir en Pixels
' Renvoie la valeur convertie en Points
'---------------------------------------------------------------------------------------
Private Function PixelToPointsY(pPixelsY As Long) As Long
    Static Mult As Single
    Dim hdc As Long
    If Mult = 0 Then
        hdc = GetDC(0)
        Mult = 1440 / GetDeviceCaps(hdc, LOGPIXELSY)
        ReleaseDC 0, hdc
    End If
    PixelToPointsY = pPixelsY * Mult
End Function
 
'---------------------------------------------------------------------------------------
' Index de l'élément sous la souris
'---------------------------------------------------------------------------------------
' pList : Valeur a convertir en Pixels
' Renvoie l'index de l'élément sous la souris
' Premier élément = 0
' Pas d'élément survolé = -1
' Peut renvoyer un index = ListCount si on survole le bas de la liste
'---------------------------------------------------------------------------------------
Private Function GetMouseIndex(pList As Access.ListBox) As Long
    Dim lLeft As Long, lTop As Long, lWidth As Long, lHeight As Long
    Dim lLeftList As Long, lTopList As Long, lWidthList As Long, lHeightList As Long
    Dim lLeftLast As Long, lTopLast As Long, lWidthLast As Long, lHeightLast As Long
    Dim lindex As Variant
    Dim lPt As PointAPI
    On Error GoTo Gestion_Erreurs
    GetCursorPos lPt
    lindex = pList.accHitTest(lPt.X, lPt.Y)
    Call pList.accLocation(lLeft, lTop, lWidth, lHeight, lindex)
    If IsEmpty(lindex) Then
        GetMouseIndex = -1
        Exit Function
    End If
    Call pList.accLocation(lLeftList, lTopList, lWidthList, lHeightList, ByVal 0&)
    Call pList.accLocation(lLeftLast, lTopLast, lWidthLast, lHeightLast, ByVal pList.ListCount)
    If lPt.X >= lLeft And lPt.X <= lLeft + lWidthList And lPt.Y >= lTop And lPt.Y <= lTop + lHeight Then
        GetMouseIndex = lindex - 1
    ElseIf lindex = 1 And lPt.X >= lLeftList And lPt.X <= lLeftList + lWidthList And lPt.Y >= lTopLast + lHeightLast And lPt.Y <= lTopList + lHeightList Then
        GetMouseIndex = pList.ListCount
    Else
        GetMouseIndex = -1
    End If
    Exit Function
Gestion_Erreurs:
    GetMouseIndex = -1
End Function

(Vous pouvez aussi importer ou copier-coller le formulaire FormDrag de la base de données exemple)

Fonction :
- Initialize : pour définir les 2 zones de liste

Evénement :
- BeginDrag : on commence à glisser un élément
- IsDragging : l'élément survolé change
- Drop : on relâche l'élément sur une des 2 listes
- EndDrag : fin du "glisser", on a relâché la souris

Il faut :
1 - déclarer un objet formulaire avec évènements :

Code :

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

1
2
 
Private WithEvents oFormDrag As Form_FormDrag

2 - Initialiser l'objet, par exemple au chargement du formulaire contenant les listes :

Code :

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

1
2
3
 
Set oFormDrag = New Form_FormDrag
oFormDrag.Initialize Me.ListeGauche, Me.ListeDroite

3 - Utiliser les événements qui se déclenchent lors des différentes étapes du drag&drop

Comment ça marche?
Pour trouver l'élément survolé par la souris et sa position, j'utilise les fonctions d'accessibilité
Pour positionner le cadre et limiter l'affichage du formulaire à un rectangle évidé : quelques API user32 et gdi32.

**Kloun** · 08/03/2009, 11h51

Sympa. Faut que j'me trouve une appli dans laquelle l'utiliser.

**Chrysostome** · 13/04/2012, 12h20

Sur Access 2003, tout simplement formidable! Ça fait à peu près 1 siècle que je cherche à avoir un système simple pour la répartition du personnel dans plusieurs endroits. Reste maintenant à voir si ça fonctionne avec 10 listes. Merci.

Pas vraiment! Si tu as une idée ...

Glisser-déposer entre deux zones de listes [Sources]

Contribuez

Discussions similaires

Partager

Partager