INTEGRATION AUTOMATIQUE DE LA ROULETTE/MOLETTE DE LA SOURIS DANS VOS APPLIS

Signaler
Messages postés
13280
Date d'inscription
lundi 13 décembre 2004
Statut
Modérateur
Dernière intervention
3 février 2018
-
Messages postés
281
Date d'inscription
jeudi 24 mars 2005
Statut
Membre
Dernière intervention
18 mars 2009
-
Cette discussion concerne un article du site. Pour la consulter dans son contexte d'origine, cliquez sur le lien ci-dessous.

https://codes-sources.commentcamarche.net/source/51291-integration-automatique-de-la-roulette-molette-de-la-souris-dans-vos-applis

Messages postés
281
Date d'inscription
jeudi 24 mars 2005
Statut
Membre
Dernière intervention
18 mars 2009

En gardant l'idée du composant + la source géniale de Renf et la proposition de Philippe734, en définitive j'ai réécris mon composant comme ci-dessous:

Classe ClsWheel
---------------
Option Explicit
Implements ISubclasser
Private mtWin1 As SubClassedWindow
Public Event WheelAction(ByVal peWheelAction As Long, ByVal plSens As Long)

Public Sub Init(ByVal plHwnd As Long)
InitiateSubClassing mtWin1, Me, plHwnd, True
End Sub

Private Function ISubclasser_WindowProc(ByVal hWnd As Long, ByVal uMsg As MessageConstants, ByVal wParam As Long, ByVal lParam As Long) As Long
If hWnd <> mtWin1.hWnd Then Exit Function

ISubclasser_WindowProc = CallOldProc(mtWin1, hWnd, uMsg, wParam, lParam)
Select Case uMsg
Case WM_MBUTTONDOWN: RaiseEvent WheelAction(wa_WheelDown, 0)
Case WM_MBUTTONUP: RaiseEvent WheelAction(wa_WheelUP, 0)
Case WM_MBUTTONDBLCLK: RaiseEvent WheelAction(wa_WheelDoubleClick, 0)
Case WM_MOUSEWHEEL:
'wParam indique le mouvement de la molette
'pour wParam négatif, c'est pour voir en haut
'positif, on descend le curseur du scrollbar
RaiseEvent WheelAction(wa_WheelMove, IIf(wParam < 0, 1, -1))
End Select
End Function

Private Sub Class_Terminate()
TerminateSubClassing mtWin1
End Sub

Usercontrol SNA_Wheel
---------------------
Option Explicit

'Valeurs de propriétés par défaut:
Private Const m_def_ScrollLines = 3

Public Enum EnumWheelAction
wa_WheelDown = 1
wa_WheelUP = 2
wa_WheelDoubleClick = 3
wa_WheelMove = 4
End Enum

Private mlScrollLines As Long
Private WithEvents moClsWheel As ClsWheel

'Déclarations d'événements:
Public Event WheelAction(ByVal peWheelAction As EnumWheelAction, ByVal plScrollLines)

'Activation de la capture de la molette sur une fenetre, par défaut celle du conteneur
Public Sub Activate(Optional ByVal plHwnd As Long = 0)
If plHwnd = 0 Then moClsWheel.Init UserControl.Parent.hWnd Else moClsWheel.Init plHwnd
End Sub

'ATTENTION! NE SUPPRIMEZ PAS OU NE MODIFIEZ PAS LES LIGNES COMMENTÉES SUIVANTES!
'MemberInfo=8,0,0,3
Public Property Get ScrollLines() As Long
ScrollLines = mlScrollLines
End Property

Public Property Let ScrollLines(ByVal New_ScrollLines As Long)
mlScrollLines = New_ScrollLines
If Not Ambient.UserMode Then PropertyChanged "ScrollLines"
End Property

Private Sub moClsWheel_WheelAction(ByVal peWheelAction As EnumWheelAction, ByVal plSens As Long)
Select Case plSens
Case -1: RaiseEvent WheelAction(peWheelAction, -mlScrollLines)
Case 1: RaiseEvent WheelAction(peWheelAction, mlScrollLines)
Case 0: RaiseEvent WheelAction(peWheelAction, 0)
End Select
End Sub

'Initialiser les propriétés pour le contrôle utilisateur
Private Sub UserControl_InitProperties()
mlScrollLines = m_def_ScrollLines
End Sub

'Charger les valeurs des propriétés à partir du stockage
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
mlScrollLines = PropBag.ReadProperty("ScrollLines", m_def_ScrollLines)
End Sub

'Écrire les valeurs des propriétés dans le stockage
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
Call PropBag.WriteProperty("ScrollLines", mlScrollLines, m_def_ScrollLines)
End Sub

Private Sub UserControl_Initialize()
Set moClsWheel = New ClsWheel
End Sub

Private Sub UserControl_Terminate()
Set moClsWheel = Nothing
End Sub

Il suffit de déposer le composant SNA_Wheel sur un form, qu'on activera sur l'évènement Load.
Private Sub Form_Load()
SNA_Wheel1.Activate
End Sub

Les evènements seront gérés comme ci-dessous.
Private Sub SNA_Wheel1_WheelAction(ByVal peWheelAction As Prj_SNAWheel.EnumWheelAction, ByVal plScrollLines As Variant)
Select Case peWheelAction
Case wa_WheelDoubleClick: Label1.Caption = "Wheel DoubleClick"
Case wa_WheelDown: Label1.Caption = "Wheel Down"
Case wa_WheelMove: Label1.Caption = "Wheel Move - Step=" & plScrollLines
Case wa_WheelUP: Label1.Caption = "Wheel Up"
End Select
End Sub

Question : Le composant étant invisible en mode runtime, l'évènement Show du Usercontrol est sans effet, comment pourrait-on faire pour que la capture de la molette s'active automatiquement sur l'évènement Load du form conteneur?. Le but étant de se passer de SNA_Wheel1.Activate sur Load. Le top étant d'avoir la capture par le seul fait de déposer le composant dans une form.
Messages postés
281
Date d'inscription
jeudi 24 mars 2005
Statut
Membre
Dernière intervention
18 mars 2009

Merci Philippe734, ca marche nickel, j'adopte ta proposition c'est plus propre à mon avis et comme j'étais à ma première concernant le subclassing, la source vbfrance.com/codes/MODULE-SUBCLASSER_38442.aspx de renf devrait régler certains de mes soucis dont je n'ai pas la parfaite connaissance, je lui fais confiance.
Messages postés
309
Date d'inscription
lundi 16 décembre 2002
Statut
Membre
Dernière intervention
15 juin 2015
1
Comme j'ai aimé ton idée d'intégrer l'évènement molette et que j'adore utiliser les modules de renfield, alors j'ai reproduit ton idée avec ses modules :

' Dans un module de class nommé CMouseWheel :
Implements ISubclasser
Private mtWin1 As SubClassedWindow
Public Event MouseWheel(Orientation As Long, Click As Boolean)
Public Sub AttachTo(frm As Form)
InitiateSubClassing mtWin1, Me, frm.hWnd, True
End Sub
Private Sub Class_Terminate()
TerminateSubClassing mtWin1
End Sub
Private Function ISubclasser_WindowProc(ByVal hWnd As Long, ByVal uMsg As MessageConstants, ByVal wParam As Long, ByVal lParam As Long) As Long
If hWnd <> mtWin1.hWnd Then Exit Function
ISubclasser_WindowProc = CallOldProc(mtWin1, hWnd, uMsg, wParam, lParam)
If uMsg = WM_MOUSEWHEEL Then RaiseEvent MouseWheel(Sgn(wParam), False)
If uMsg = WM_MBUTTONUP Then RaiseEvent MouseWheel(Sgn(wParam), True)
End Function

' Intégration de l'évènement molette dans une form :
Private WithEvents FormX As CMouseWheel
Private Sub Form_Load()
Set FormX = New CMouseWheel
FormX.AttachTo Me
End Sub
Private Sub FormX_MouseWheel(Orientation As Long, Click As Boolean)
'If Orientation < 0 Then ' On scroll vers le bas
End Sub

Bon, tout ça pour dire que c'est juste pour le plaisir d'utiliser le subclassing facilement.
Messages postés
309
Date d'inscription
lundi 16 décembre 2002
Statut
Membre
Dernière intervention
15 juin 2015
1
Merci, en plus, j'aime bien le concept de portabilité pour d'autres appli. En revanche, dans le projet test, le subclassing n'est pas terminée, alors que tu voulais le terminé lorsque la souris sort du datagrid. Je pense que le mieux d'ajouter la fin du subclassing dans form_terminate. Comme tu apprécie le subclassing, alors pour explorer cet univers, je te conseil d'utiliser les modules de rendfield :
vbfrance.com/codes/MODULE-SUBCLASSER_38442.aspx
Afficher les 11 commentaires