Usercontrol et les Messages WM_MOUSEHOVER et WM_MOUSELEAVE

Question

Salut, j'ai un activex qui sert de Label, dont je voudrais ajouter le MouseHover et MouseLeave, j'ai trouvé quelques sources comment sous-classer, mais dans ma sub qui capte les messages je ne reçoit jamais les messages MouseLeave et MouseHover, pourtant j'ai bien applé l'API TrackMouseEvent

A moins que ces messages ne soient jamais passé a un usercontrol ?

Quelqu'un aurait-il une solution ? :)

Voici le code de mon label:

Option Explicit

'Constant for Windows Message used in sample.
Private Const WM_MOUSEHOVER = &H2A1
Private Const WM_MOUSELEAVE = &H2A3

Private Const DT_LEFT = &H0
Private Const DT_CENTER = &H1
Private Const DT_RIGHT = &H2
Private Const DT_WORDBREAK = &H10
Private Const DT_CALCRECT = &H400

Public Event Click()
Public Event DblClick()

Public Event MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Public Event MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
Public Event MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Public Event MouseLeave()
Public Event MouseHover()

Private Type RECT

    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
    
End Type

Private Declare Function DrawText Lib "user32" Alias "DrawTextA" _
(ByVal hDC As Long, ByVal lpStr As String, ByVal nCount As Long, _
lpRect As RECT, ByVal wFormat As Long) As Long

Enum ATLblAlignmentConst

  alLeftTop
  alLeftMiddle
  alLeftBottom
  alCenterTop
  alCenterMiddle
  alCenterBottom
  alRightTop
  alRightMiddle
  alRightBottom
  
End Enum

Const m_def_Alignment = ATLblAlignmentConst.alLeftMiddle

Private m_Caption As String
Private m_WordWrap As Integer
Private m_Alignment As ATLblAlignmentConst
Public iHeight As Integer

Private Sub UserControl_Click()

    RaiseEvent Click
    
End Sub

Private Sub UserControl_DblClick()

    RaiseEvent DblClick

End Sub

'Private Sub UserControl_HitTest(x As Single, y As Single, HitResult As Integer)
' c'était pour pouvoir le rendre transparent, mais pour sous-classer on doit avoir
un hwnd alors le windowless doit être a false donc pas de transparence.
'    If HitResult = vbHitResultOutside Then
'
'        HitResult = vbHitResultHit
'
'    End If
'
'End Sub

Private Sub UserControl_InitProperties()

    On Error Resume Next
    m_Caption = Extender.Name
    Set UserControl.Font = Ambient.Font
    m_Alignment = m_def_Alignment

    
End Sub

Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)

    RaiseEvent MouseDown(Button, Shift, x, y)

End Sub

Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    
    RaiseEvent MouseMove(Button, Shift, x, y)

End Sub

Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)

    RaiseEvent MouseUp(Button, Shift, x, y)

End Sub

Private Sub UserControl_Paint()
  
    RePaint

End Sub

Public Property Get Caption() As String

    Caption = m_Caption
    
End Property

Public Property Let Caption(ByVal New_Caption As String)

    m_Caption = New_Caption
    Refresh
    PropertyChanged "Caption"
  
End Property

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)

    m_Caption = PropBag.ReadProperty("Caption", vbNullString)
    
    UserControl.BackColor = PropBag.ReadProperty("BackColor", &H8000000F)
    UserControl.ForeColor = PropBag.ReadProperty("ForeColor", &H80000012)
    
    Set UserControl.MouseIcon = PropBag.ReadProperty("MouseIcon", Nothing)
    
    UserControl.MousePointer = PropBag.ReadProperty("MousePointer", vbDefault)
    
    m_WordWrap = PropBag.ReadProperty("WordWrap", False)
    
    Set UserControl.Font = PropBag.ReadProperty("Font", Ambient.Font)
    
    m_Alignment = PropBag.ReadProperty("Alignment", m_def_Alignment)
     
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)

    Call PropBag.WriteProperty("Caption", m_Caption, vbNullString)
    Call PropBag.WriteProperty("BackColor", UserControl.BackColor, &H8000000F)
    Call PropBag.WriteProperty("ForeColor", UserControl.ForeColor, &H80000012)
    Call PropBag.WriteProperty("MouseIcon", UserControl.MouseIcon, Nothing)
    Call PropBag.WriteProperty("MousePointer", UserControl.MousePointer, vbDefault)
    Call PropBag.WriteProperty("WordWrap", m_WordWrap, False)
    Call PropBag.WriteProperty("Font", UserControl.Font, Ambient.Font)
    Call PropBag.WriteProperty("Alignment", m_Alignment, m_def_Alignment)
    
End Sub

Public Property Get BackColor() As OLE_COLOR

    BackColor = UserControl.BackColor
    
End Property

Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)

    UserControl.BackColor() = New_BackColor
    Refresh
    PropertyChanged "BackColor"
    
End Property

Public Property Get Font() As Font

    Set Font = UserControl.Font
    
End Property

Public Property Set Font(ByVal New_Font As Font)

    Set UserControl.Font = New_Font
    Refresh
    PropertyChanged "Font"
    
End Property

Public Property Get Alignment() As ATLblAlignmentConst

    Alignment = m_Alignment
    
End Property

Public Property Let Alignment(ByVal New_Alignment As ATLblAlignmentConst)

    m_Alignment = New_Alignment
    UserControl.Refresh
    PropertyChanged "Alignment"
    
End Property

Private Sub RePaint()

  Dim lpRect As RECT, ht As Long

  With lpRect
    .Left = 0
    .Top = 0
    .Right = UserControl.ScaleWidth
    .Bottom = UserControl.ScaleHeight
    ht = DrawText(UserControl.hDC, m_Caption, Len(m_Caption), lpRect, DT_CALCRECT Or m_WordWrap)

    .Right = UserControl.ScaleWidth
    .Bottom = UserControl.ScaleHeight
    Select Case m_Alignment
    Case alLeftMiddle, alCenterMiddle, alRightMiddle
      .Top = (ScaleHeight - ht) \ 2
      .Bottom = .Bottom + .Top
    Case alLeftBottom, alCenterBottom, alRightBottom
      .Top = (ScaleHeight - ht)
      .Bottom = .Bottom + .Top
    End Select
    Select Case m_Alignment
    Case alLeftTop, alLeftMiddle, alLeftBottom
      ht = DT_LEFT Or m_WordWrap
    Case alCenterTop, alCenterMiddle, alCenterBottom
      ht = DT_CENTER Or m_WordWrap
    Case alRightTop, alRightMiddle, alRightBottom
      ht = DT_RIGHT Or m_WordWrap
    End Select
  End With
  
  iHeight = DrawText(UserControl.hDC, m_Caption, Len(m_Caption), lpRect, ht)
  
End Sub

Public Property Get ForeColor() As OLE_COLOR

    ForeColor = UserControl.ForeColor
    
End Property

Public Property Let ForeColor(ByVal New_ForeColor As OLE_COLOR)

    UserControl.ForeColor() = New_ForeColor
    Refresh
    PropertyChanged "ForeColor"
    
End Property

Public Property Let WordWrap(NewData As Boolean)

    m_WordWrap = IIf(NewData, DT_WORDBREAK, 0)
    Refresh
    PropertyChanged "WordWrap"
    
End Property

Public Property Get WordWrap() As Boolean
    WordWrap IIf(m_WordWrap DT_WORDBREAK, True, False)
    
End Property

Public Property Get MousePointer() As MousePointerConstants

    MousePointer = UserControl.MousePointer
    
End Property

Public Property Let MousePointer(ByVal New_MousePointer As MousePointerConstants)

    UserControl.MousePointer = New_MousePointer
    PropertyChanged "MousePointer"
    
End Property

Public Property Get MouseIcon() As StdPicture

    Set MouseIcon = UserControl.MouseIcon
  
End Property

Public Property Set MouseIcon(ByVal New_MouseIcon As StdPicture)

    Set UserControl.MouseIcon = New_MouseIcon
    PropertyChanged "MouseIcon"
    
End Property

Renfield · Answer

La source là :
http://www.vbfrance.com/codes/TUTORIEL-OCX-BASIQUE_32545.aspx

te propose ces évènements, sans utiliser de SubClassing.

Renfield
Admin CodeS-SourceS- MVP Visual Basic

Mew27 · Answer

Ok :) Mais je préfèrerais utiliser le subclassing pour l'intégrer à mon activex :)

Renfield · Answer

ok,

appelle trackmouseEvents lors du WM_MOUSEMOVE

Declare Function TrackMouseEvents Lib "comctl32" Alias "_TrackMouseEvent" (lpEventTrack As TRACKMOUSEEVENTTYPE) As Long

Renfield
Admin CodeS-SourceS- MVP Visual Basic

Mew27 · Answer

Ok, mais c'est ce que j'ai fait, mais tout ce qui arrive c'est le mousehover qui se déclenche une fois et ensuite plus rien, c'est bizarre.

Ce que j'ai fait, j'ai fait:

Pour le subclassing j'ai utilisé ceci:
http://www.vbfrance.com/codes/MODULE-SUBCLASSER_38442.aspx

J'ai mit dans le code de mon usercontrol
Implements ISubClasser


Private Const SC_MINIMIZE As Long = &HF020&

PublicEnum TrackMouseEventFlags
     TME_HOVER = &H1
     TME_LEAVE = &H2
     TME_NONCLIENT = &H10
     TME_QUERY = &H40000000
     TME_CANCEL = &H80000000
EndEnum

PrivateType TRACKMOUSESTRUCT
    cbSize AsLong
    dwFlags As TrackMouseEventFlags '\ TrackMouseEvents
    hwndTrack AsLong'\ Target window
    dwHoverTime AsLong'\ Mouse hover timeout in milliseconds
EndType
PrivateDeclareFunction TrackMouseEvent Lib "user32" (lpTrackMouseStruct As TRACKMOUSESTRUCT) AsLong


Public Sub UserControl_Initialize()

     dim mousestruct as TRACKMOUSESTRUCT

      mousestruct.cbSize = len(mousestruct)
      mousestruct.Flags = TME_HOVER Or TME_LEAVE
      mousestruct.hwndTrack = Usercontrol.hWnd
      mousestruct.dwHoverTime = 1000

     call TrackMouseEvent(mousestruct)

     ModSubClasser.StartGenericCallBack Usercontrol, Usercontrol.hWnd

End Sub


Private Function ISubClasser_ProcessMessages(ByVal hWnd As Long, ByVal uMsg As MessageConstants, ByVal wParam As Long, ByVal lParam As Long, veBehavior As MsgBehaviorConstants) As Long
    If uMsg = WM_MOUSEHOVER then
         debug.pring "mouseover"
    elseif uMsg = WM_MOUSELEAVE then
        debug.print "mouseleave"
    End If
End Function

Et quand je lance l'application j'ai tout de suite "mouseleave" qui apparait une seule fois seulement.

Renfield · Answer

"appelle trackmouseEvents lors du WM_MOUSEMOVE"

la demande de notification n'est valable que pour une fois...
tu peux mettre le 
mousestruct.dwHoverTime = 1000
à 1 :
mousestruct.dwHoverTime = 1

Renfield
Admin CodeS-SourceS- MVP Visual Basic

Mew27 · Answer

Ok :)

Mais quand j'essaie de démarrer mon projet j'ai l'erreur suivante:

Private Enum Type and Enum Type defined in standard modules  or private class cannot be used in public project as parameters or return type for public procedures as public data members or as field or public user defined types

Il fait ça sur Public Function ProcessMessages(ByVal hWnd As Long, ByVal uMsg As MessageConstants, ByVal wParam As Long, ByVal lParam As Long, veBehavior As MsgBehaviorConstants) As Long

Dans la class ISubclasser, j'ai essayé de le mettre à Multiuse et j'ai mit les enum public dans le module ModSubclasser, mais j'ai toujours cette erreur.

Mew27 · Answer

Bonjour, là j'ai mit les enum public du modules modSubclasser et je les ait placés dans le usercontrol au lieu du module, maintenant j'ai une erreur: Dépendances circulaires des modules.


Qu'est-ce que je fais de pas correct ?

Renfield · Answer

Mets tout ce qui est API en Public dans un Module  (Declare function / Anums et constantes)

et ne fais pas de doublons... il ne les faut que dans ce module.

Renfield
Admin CodeS-SourceS- MVP Visual Basic

Mew27 · Answer

Ok, mais c'était déjà le cas, mais ça ne fonctionnait pas plus. Le module modSubclasser tout les enums dedans sont public et dans la classe ISubclass la fonction est public aussi et ça donne toujours l'erreur:

Private Enum Type and Enum Type defined in standard modules  or private class cannot be used in public project as parameters or return type for public procedures as public data members or as field or public user defined types

Je ne comprends pas, as-tu une idée ? :)

Renfield · Answer

je ne vois pas trop où es ton soucis....

j'ai repris mon projet du module SubClasser,
j'aii ajouté un usercontrol, et j'y ai mis :

Option Explicit

Implements ISubClasser

Private Const SC_MINIMIZE As Long = &HF020&

Public Enum TrackMouseEventFlags
     TME_HOVER = &H1
     TME_LEAVE = &H2
     TME_NONCLIENT = &H10
     TME_QUERY = &H40000000
     TME_CANCEL = &H80000000
End Enum

Private Type TRACKMOUSESTRUCT
    cbSize As Long
    dwFlags As TrackMouseEventFlags '\ TrackMouseEvents
    hwndTrack As Long '\ Target window
    dwHoverTime As Long '\ Mouse hover timeout in milliseconds
End Type

Private Declare Function TrackMouseEvent Lib "user32" (lpTrackMouseStruct As TRACKMOUSESTRUCT) As Long

Private mousestruct As TRACKMOUSESTRUCT

Public Sub UserControl_Initialize()
    mousestruct.cbSize = Len(mousestruct)
    mousestruct.dwFlags = TME_HOVER Or TME_LEAVE
    mousestruct.hwndTrack = UserControl.hWnd
    mousestruct.dwHoverTime = 1000
     
    ModSubClasser.StartGenericCallBack Me, UserControl.hWnd
End Sub

Private Function ISubClasser_ProcessMessages(ByVal hWnd As Long, ByVal uMsg As MessageConstants, ByVal wParam As Long, ByVal lParam As Long, veBehavior As MsgBehaviorConstants) As Long
    Select Case uMsg
        Case WM_MOUSEHOVER
            Debug.Print Timer, "mouseover"
        Case WM_MOUSELEAVE
            Debug.Print Timer, "mouseleave"
        Case wm_mousemove
            Call TrackMouseEvent(mousestruct)
    End Select
End Function

Renfield
Admin CodeS-SourceS- MVP Visual Basic

adalgur · Answer

Il y a un truc plus simple pour MouseEnter et MouseLeave (je l'utilise toujours) sans subclasser 'Private Declare Function GetCapture Lib "user32" () As Long 'Private Declare Function ReleaseCapture Lib "user32" () As Long 'Private Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long 'Public Event MouseEnter() 'Public Event MouseLeave() 'Private gbMouseIn as boolean Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) If Button = 0 Then If GetCapture() <> UserControl.hwnd Then ' si la fenetre qui a la capture n'est pas le controle SetCapture UserControl.hwnd ' alors la lui donner, de façon à garder le message RaiseEvent MouseEnter ' mousemove meme en dehors du controle gbMouseIn = True 'redessiner si besoin en f(gbMouseIn) ElseIf x < 0 Or Y < 0 Or X > UserControl.ScaleWidth Or Y > UserControl.ScaleHeight) Then ReleaseCapture ' on sort des limites ' on rend la main aux autres RaiseEvent MouseLeave gbMouseIn = False 'redessiner si besoin en f(gbMouseIn) End If End Sub 'rem: si Button=1 un controle garde toujours la capture

Usercontrol et les Messages WM_MOUSEHOVER et WM_MOUSELEAVE

11 réponses

Votre réponse