Réglage de la molette

Salut,

Voila un code qui marche (je joins un projet zippé à mon prochain message,
ce sera plus facile). On peut ajouter très facilement les controles à
subclasser et mêmes s'ils sont sur différents formulaires.


'//Form1 :

Option Explicit

Private Sub Form_Load()
Dim oCtl As Object
'//On ajoute les controles qu'on veut, ici tous les listboxes du
formulaire
'//(on peut les ajouter un part un aussi : Call AddSB(List1)...
For Each oCtl In Me
If TypeOf oCtl Is ListBox Then
Call AddSB(oCtl)
End If
Next
End Sub

Private Sub Form_Unload(Cancel As Integer)
'//On UnSubClass tout avant de quitter.
Call UnSBAll
End Sub


Public Sub onMouseWheel(Direction As Integer, oCtl As Object)
'//On récupère l'événement MouseWheel pour les ListBoxes ajoutées
Call MoveListBoxTopIndex(Direction, oCtl) '// ou Call
MoveListBoxListIndex(Direction, List1)
End Sub

Public Sub MoveListBoxListIndex(wDirection As Integer, oList As ListBox)
If wDirection = 1 Then
If oList.ListIndex > 0 Then oList.ListIndex = oList.ListIndex - 1
Else
If oList.ListIndex < (oList.ListCount - 1) Then oList.ListIndex oList.ListIndex + 1
End If
End Sub

Public Sub MoveListBoxTopIndex(wDirection As Integer, oList As ListBox)
If wDirection = 1 Then
If oList.TopIndex > 0 Then oList.TopIndex = oList.TopIndex - 1
Else
If oList.TopIndex < (oList.ListCount - 1) Then oList.TopIndex oList.TopIndex + 1
End If
End Sub




'//Module1 :
Option Explicit

Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA"
(ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal
wParam As Long, ByVal lParam 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 GetCursorPos Lib "user32" (lpPoint As POINTAPI) As
Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long,
lpRect As RECT) As Long

Private Type CTL_SBCLASS
SB_ID As Long
CtlPointer As Object
End Type

Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type POINTAPI
X As Long
Y As Long
End Type

Private Const WHEEL_DELTA = 120
Private Const WHEEL_PAGESCROLL = &HFFFFFFFF
Private Const WM_MOUSEWHEEL = &H20A


Private Const GWL_WNDPROC As Long = -4
Private tblSubClassedCtl() As CTL_SBCLASS
Private bInit As Boolean

Private Function SubClass(ByRef hwnd As Long) As Long
SubClass = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WindowProc)
End Function

Private Sub UnSubClass(ByRef hwnd As Long, lSB_ID As Long)
Call SetWindowLong(hwnd, GWL_WNDPROC, lSB_ID)
End Sub

Public Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal
wParam As Long, ByVal lParam As Long) As Long
Dim i As Integer, lSB_ID As Long
Dim oCtl As Object

For i = 0 To UBound(tblSubClassedCtl)
If tblSubClassedCtl(i).CtlPointer.hwnd = hwnd Then
lSB_ID = tblSubClassedCtl(i).SB_ID
Exit For '//BREAK
End If
Next

Select Case uMsg
Case WM_MOUSEWHEEL

For i = 0 To UBound(tblSubClassedCtl)
If IsCursorHover(tblSubClassedCtl(i).CtlPointer.hwnd) Then
Set oCtl = tblSubClassedCtl(i).CtlPointer
Exit For '//BREAK
End If
Next

If (HiWord(wParam) / WHEEL_DELTA) < 0 Then
Call Form1.onMouseWheel(2, oCtl)
Else
Call Form1.onMouseWheel(1, oCtl)
End If

Set oCtl = Nothing
Case Else
WindowProc = CallWindowProc(lSB_ID, hwnd, uMsg, wParam, lParam)
End Select


End Function
Private Function HiWord(dw As Long) As Integer
If dw And &H80000000 Then
HiWord = (dw 65535) - 1
Else
HiWord = dw 65535
End If
End Function
Private Function LoWord(dw As Long) As Integer
If dw And &H8000& Then
LoWord = &H8000 Or (dw And &H7FFF&)
Else
LoWord = dw And &HFFFF&
End If
End Function

Public Sub UnSBAll()
Dim i As Integer
For i = 0 To UBound(tblSubClassedCtl)
Call UnSubClass(tblSubClassedCtl(i).CtlPointer.hwnd,
tblSubClassedCtl(i).SB_ID)
Set tblSubClassedCtl(i).CtlPointer = Nothing
Next
Erase tblSubClassedCtl
bInit = False
End Sub

Public Sub AddSB(oCtl As Object)
Dim lInd As Long
If Not bInit Then
bInit = True
lInd = 0
Else
lInd = UBound(tblSubClassedCtl) + 1
End If
ReDim Preserve tblSubClassedCtl(lInd)
Set tblSubClassedCtl(lInd).CtlPointer = oCtl
tblSubClassedCtl(lInd).SB_ID = SubClass(oCtl.hwnd)
End Sub

Private Function IsCursorHover(lhWnd As Long) As Boolean
Dim tCursorPos As POINTAPI, tCtlRect As RECT
Call GetCursorPos(tCursorPos)
Call GetWindowRect(lhWnd, tCtlRect)
IsCursorHover = (tCursorPos.X >= tCtlRect.Left And tCursorPos.X < tCtlRect.Right) And _
(tCursorPos.Y >= tCtlRect.Top And tCursorPos.Y < tCtlRect.Bottom)
End Function



--
Nicolas G.
FAQ VB : http://faq.vb.free.fr
API Guide : http://www.allapi.net
Google Groups : http://groups.google.fr/
MZ-Tools : http://www.mztools.com/

Barsalou wrote:

Salut

Je n'ai pas réussi à me démerder. J'ai fait quelques essais qui ont eu
essentiellement pour effet de me planter.

Il faut dire que je ne connais rien à l'idée de sous-classer.

Ce serait super si pouvais me faire un exemple avec un petit groupe de
ListBox (ou mieux deux groupes).

J'espérais naïvement qu'il existait une API permettant de modifie les
paramètres de la molette. Je n'ai rien trouvé.

Merci en tout cas de tes efforts.