Teuk65
Messages postés13Date d'inscriptionlundi 16 août 2010StatutMembreDernière intervention24 septembre 2010
-
26 août 2010 à 12:20
Teuk65
Messages postés13Date d'inscriptionlundi 16 août 2010StatutMembreDernière intervention24 septembre 2010
-
30 août 2010 à 17:48
Bonjour!
Je viens d'écrire un code utilisant sur une TreeView les évènements MouseDown, MouseMove et MouseUp, seulement l'évènement MouseUp se déclenche dans la plupart des cas, sauf dans le cas ou il serait vraiment utile.
Pour info, c'est un code reprogrammant le drag/drop, vu qu'il n'est pas correctement implémenté dans VBA. J'ai trouvé d'autres codes sur internet pour le faire, mais comme je n'arrive pas à les comprendre, j'ai fait le mien.
voici le code:
Private Sub TreeView2_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As stdole.OLE_XPOS_PIXELS, ByVal y As stdole.OLE_YPOS_PIXELS)
Dim XFactor As Double, YFactor As Double
XFactor = PixelsPerInch(88)
YFactor = PixelsPerInch(90)
Label11.Caption = "MouseDown"
Set TreeView2.DropHighlight = TreeView2.HitTest(x * 1440 / XFactor, y * 1440 / YFactor)
TreeView2.SelectedItem = TreeView2.HitTest(x * 1440 / XFactor, y * 1440 / YFactor)
Set objDragNode = TreeView2.SelectedItem
End Sub
Private Sub TreeView2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As stdole.OLE_XPOS_PIXELS, ByVal y As stdole.OLE_YPOS_PIXELS)
On Error Resume Next
Dim XFactor As Double, YFactor As Double
XFactor = PixelsPerInch(88)
YFactor = PixelsPerInch(90)
If Button = 1 Then
TreeView2.SelectedItem = TreeView2.HitTest((x * (1)) * 1440 / XFactor, (y * (1)) * 1440 / YFactor)
Set objDestNode = TreeView2.HitTest(x * 1440 / XFactor, y * 1440 / YFactor)
End If
End Sub
Private Sub TreeView2_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As stdole.OLE_XPOS_PIXELS, ByVal y As stdole.OLE_YPOS_PIXELS)
On Error GoTo erreurdrag
Label11.Caption = "MouseUp"
If (Not objDestNode Is Nothing) And (Not objDragNode Is Nothing) Then
Set objDragNode.Parent = objDestNode
boFlagEC = False
End If
Exit Sub
erreurdrag:
If Err.Number = 35614 Then
MsgBox ("Erreur circulaire")
Else
MsgBox ("autre erreur")
End If
End Sub
Commentaires sur le code:
- objDragNode est le noeud qu'on veut déplacer, objDestNode est le noeud parent dans lequel on veut le placer
- la fonction PixelsPerInch est un code trouvé sur internet utiles car la fonction HitTest fonctionne en twips et les x et y sont en pixels dans les TreeView (et quelques autres controles) en VBA, il faut donc faire une conversion
- Gestion des erreurs: l'erreur circulaire intervient quand on place un noeud su lui même, il devient alors son propre parent.
- L'évènement MouseUp se déclenche quand objDragNode est vide (la valeur de HitTest peut changer) ou quand on ne déplace pas la souris plus loin que le Node choisi au départ (quand la valeur de HitTest ne change pas donc). On a alors l'erreur circulaire.
Teuk65
Messages postés13Date d'inscriptionlundi 16 août 2010StatutMembreDernière intervention24 septembre 20102 30 août 2010 à 17:48
Au risque de monologuer et de me faire virer du forum pour flood, j'ai trouvé une solution en
relisant mon message.
Immédiatement après l'évènement MouseUp, VBA déclenche un MouseMove, qui se déclenche aussi
quand le MouseUp refuse de se lancer, avec l'argument Button à 0.
Il suffit donc de mettre un flag dans MouseMove à True lorsqu'on effectue le Drag/Drop, et de
vérifier sa valeur lors d'un MouseMove et que le bouton est à 0.
J'obtiens donc finalement ce code, que je partage volontiers puisqu'il permet de programmer
simplement un drag and drop (glisser/déposer) dans un TreeView en VBA
Private Sub TreeView1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer,_
ByVal x As stdole.OLE_XPOS_PIXELS, ByVal y As stdole.OLE_YPOS_PIXELS) 'clic sur le treeview
Dim XFactor As Double, YFactor As Double
XFactor = x * 1440 / PixelsPerInch(88) 'fonctions de correction des coordonnées
YFactor = y * 1440 / PixelsPerInch(90)
If Button = 1 Then 'si clic gauche
TreeView1.SelectedItem = TreeView1.HitTest(XFactor, YFactor) 'sélection du noeud cliqué
Set objDragNode = TreeView1.HitTest(XFactor, YFactor) 'affectation a la variable du noeud cliqué
Else 'si pas de clic ou autre clic
Set objDragNode = Nothing 'vidage des variables objet
Set objDestNode = Nothing
End If
End Sub
Private Sub TreeView1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer,_
ByVal x As stdole.OLE_XPOS_PIXELS, ByVal y As stdole.OLE_YPOS_PIXELS) 'déplacement de la souris sur le treeview
Dim XFactor As Double, YFactor As Double
XFactor = x * 1440 / PixelsPerInch(88) 'fonctions de correction des coordonnées
YFactor = y * 1440 / PixelsPerInch(90)
If Button = 1 Then 'si clic gauche
TreeView1.SelectedItem = TreeView1.HitTest(XFactor, YFactor) 'sélection du noeud survolé
Set objDestNode = TreeView1.HitTest(XFactor, YFactor) 'affectation du noeud survolé a la variable
If objDestNode Is Nothing Or objDestNode = objDragNode Then
TreeView1.MousePointer = ccNoDrop 'curseur "interdit" si déplacement impossible
Else
TreeView1.MousePointer = ccArrow 'curseur normal
dragflag = True 'on indique qu'un drag and drop est en cours
Else 'si pas de clic ou autre clic
If dragflag Then 'si un drag and drop est en cours
Call drop 'fonction qui finalise de drag drop
dragflag = False 'fin du drag and drop
End If
Set objDragNode = Nothing 'vidage des variables objet
Set objDestNode = Nothing
End If
End Sub
Sub drop()
On Error GoTo erreurdrag
TreeView1.MousePointer = ccArrow 'réinitialisation du curseur
'si les 2 objets (noeud de départ et d'arrivée) ne sont pas vides
If (Not objDestNode Is Nothing) And (Not objDragNode Is Nothing) Then
Set objDragNode.Parent = objDestNode 'déplacement du noeud
End If
Set objDragNode = Nothing 'vidage des objets
Set objDestNode = Nothing
Exit Sub
erreurdrag:
If Err.Number = 35614 Then 'erreur circulaire, le noeud est placé sur lui meme ou sur un de ses enfants
Call MsgBox ("Erreur circulaire", vbExclamation + vbOKOnly, "Erreur")
Else 'autre erreur
Call MsgBox("Erreur " & Err.Number & Chr(13) & Err.Description, vbExclamation + vbOKOnly, "Erreur")
End If
End Sub
'Fonction de correction des coordonnées, merci a kjby2K du forum Xtreme VB Talk
'http://www.xtremevbtalk.com/showthread.php?t=282098
Public Function PixelsPerInch(Par As Integer) As Double
Dim hDC As Long
Dim lDotsPerInch As Long
hDC = GetDC(0)
lDotsPerInch = GetDeviceCaps(hDC, Par)
PixelsPerInch = lDotsPerInch
ReleaseDC 0, hDC
End Function
Les variables objDragNode, objDestNode et dragflag sont déclarées en Public, As Object et As Boolean respectivement
Je n'avais pas réussi a faire marcher d'autres codes ayant la même fonction glanés sur le web.
Si celui ci fonctionne pour moi, je souhaite que ce soit le cas pour les autres!
Teuk65
Messages postés13Date d'inscriptionlundi 16 août 2010StatutMembreDernière intervention24 septembre 20102 30 août 2010 à 17:14
Permettez moi de relancer ce post mais je ne trouve aucune piste pour résoudre ce problème.
J'ai fait pas mal d'essais et il semble que MouseUp réagit bizarrement dans un treeview.
J'ai réduit mon code à ceci:
Private Sub TreeView1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer,_
ByVal x As stdole.OLE_XPOS_PIXELS, ByVal y As stdole.OLE_YPOS_PIXELS)
Label11.Caption = "MouseDown"
End sub
Private Sub TreeView1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer,_
ByVal x As stdole.OLE_XPOS_PIXELS, ByVal y As stdole.OLE_YPOS_PIXELS)
Label11.Caption = "MouseUp"
End sub
Rien de bien extraordinaire, quand je clique quelque part dans mon TreeView, mon Label affiche MouseDown,
et quand je relache le clic, ca affiche MouseUp.
Quand je clique "dans le vide" puis que je me déplace puis que je relache, mon label affiche au final "MouseUp".
Quand je clique sur un noeud puis que je relache, j'obtiens au final "MouseUp".
Par contre, quand je clique sur le noeud, que je me déplace (vers un autre noeud, "dans le vide" ou
a l'extérieur du treeview, peu importe), le Label affiche au final "MouseDown", ce qui veut dire que
le sub MouseUp n'a pas été appelé. Etrange
Donc à défaut de faire faire marcher MouseUp, quelqu'un a-t-il une idée pour contourner le problème?