Evènement MouseUp qui ne se déclenche pas

Signaler
Messages postés
13
Date d'inscription
lundi 16 août 2010
Statut
Membre
Dernière intervention
24 septembre 2010
-
Messages postés
13
Date d'inscription
lundi 16 août 2010
Statut
Membre
Dernière intervention
24 septembre 2010
-
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.

Merci de votre aide

2 réponses

Messages postés
13
Date d'inscription
lundi 16 août 2010
Statut
Membre
Dernière intervention
24 septembre 2010
2
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!
Messages postés
13
Date d'inscription
lundi 16 août 2010
Statut
Membre
Dernière intervention
24 septembre 2010
2
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?

Merci de votre aide