la molette de souris et msflexgrid

Salut


Pour activer
TrackMouseWheel MSFlexGrid1.hWnd

Pour désactiver
UnTrackMouseWheel MSFlexGrid1.hWnd


C'est pas de moi c'Est un code de
http://www.planet-source-code.com/
dans un module

Option Explicit

Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any,
pSource As Any, ByVal dwLength As Long)

Private Const WM_MOUSEWHEEL As Long = &H20A
Private Const WM_DESTROY As Long = &H2

Private Const WM_HSCROLL As Long = &H114
Private Const WM_VSCROLL As Long = &H115
Private Const SB_LINEDOWN As Long = 1
Private Const SB_LINEUP As Long = 0
Private Const SB_PAGEUP As Long = 2
Private Const SB_PAGEDOWN As Long = 3

Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA"
( _
ByVal hWnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Private Declare Function GetParent Lib "user32.dll" ( _
ByVal hWnd As Long) As Long

Private Declare Function GetClientRect Lib "user32.dll" ( _
ByVal hWnd As Long, _
lpRect As RECT) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function ScreenToClient Lib "user32.dll" ( _
ByVal hWnd As Long, _
lpPoint As POINTAPI) As Long

Private Declare Function PtInRect Lib "user32.dll" ( _
lpRect As RECT, _
ByVal x As Long, _
ByVal y As Long) As Long

Private Declare Function GetWindowPlacement Lib "user32.dll" ( _
ByVal hWnd As Long, _
lpwndpl As WINDOWPLACEMENT) As Long
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type WINDOWPLACEMENT
Length As Long
flags As Long
showCmd As Long
ptMinPosition As POINTAPI
ptMaxPosition As POINTAPI
rcNormalPosition As RECT
End Type
Private Declare Function CallWindowProc Lib "user32.dll" 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.dll" Alias
"SetWindowLongA" ( _
ByVal hWnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Private Const GWL_WNDPROC As Long = -4

Public Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hWnd As
Long, ByVal lpString As String) As Long
Public Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hWnd As
Long, ByVal lpString As String, ByVal hData As Long) As Long
Public Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal
hWnd As Long, ByVal lpString As String) As Long
Private Const OLDWNDPROC = "OldWndProc"

Private lOldWndProc As Long
Private lHwnd As Long

' Combines two integers into a long integer

Private m_iErr_Handle_Mode As Long 'Init this variable to the desired error
handling manage

Public Function MAKELONG(wLow As Long, wHigh As Long) As Long


On Error GoTo Err_Proc
MAKELONG = LOWORD(wLow) Or (&H10000 * LOWORD(wHigh))
Exit_Proc:
Exit Function


Err_Proc:
Err_Handler "Module2", "MAKELONG", Err.Description
Resume Exit_Proc


End Function

' Combines two integers into a long integer

Public Function MAKELPARAM(wLow As Long, wHigh As Long) As Long


On Error GoTo Err_Proc
MAKELPARAM = MAKELONG(wLow, wHigh)
Exit_Proc:
Exit Function


Err_Proc:
Err_Handler "Module2", "MAKELPARAM", Err.Description
Resume Exit_Proc


End Function

' Returns the low 16-bit integer from a 32-bit long integer

Public Function LOWORD(dwValue As Long) As Integer


On Error GoTo Err_Proc
MoveMemory LOWORD, dwValue, 2
Exit_Proc:
Exit Function


Err_Proc:
Err_Handler "Module2", "LOWORD", Err.Description
Resume Exit_Proc


End Function

' Returns the low 16-bit integer from a 32-bit long integer

Public Function HIWORD(dwValue As Long) As Integer


On Error GoTo Err_Proc
MoveMemory HIWORD, ByVal VarPtr(dwValue) + 2, 2
Exit_Proc:
Exit Function


Err_Proc:
Err_Handler "Module2", "HIWORD", Err.Description
Resume Exit_Proc


End Function

Public Function MouseWheelProc(ByVal hWnd As Long, _
ByVal iMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long


On Error GoTo Err_Proc

Select Case iMsg
Case WM_MOUSEWHEEL
Dim lMove As Integer
Dim lNewlParam As Long
Dim lNewwParam As Long
Dim rRect As RECT
Dim pt As POINTAPI

Dim wp As WINDOWPLACEMENT

Call GetWindowPlacement(hWnd, wp)




Call GetClientRect(hWnd, rRect)


pt.x = LOWORD(lParam)
pt.y = HIWORD(lParam)

Call ScreenToClient(GetParent(hWnd), pt)

If PtInRect(wp.rcNormalPosition, pt.x, pt.y) Then




lMove = HIWORD(wParam)
If lMove > 0 Then
'up
'multiples of 120
If lMove = 120 Then
lNewlParam = MAKELPARAM(SB_LINEUP, 0) '0, SB_LINEUP)
Else
'full page
lNewlParam = MAKELPARAM(SB_PAGEUP, 0)
End If

Call SendMessage(hWnd, WM_VSCROLL, lNewlParam, 0)
Else
'down
If lMove = -120 Then
lNewlParam = MAKELPARAM(SB_LINEDOWN, 0) ', SB_LINEDOWN)
Else
'full page
lNewlParam = MAKELPARAM(SB_PAGEDOWN, 0) ', SB_LINEDOWN)
End If

Call SendMessage(hWnd, WM_VSCROLL, lNewlParam, 0)
End If

End If
Case WM_DESTROY
' OLDWNDPROC will be gone after UnSubClass is called!
Call CallWindowProc(GetProp(hWnd, OLDWNDPROC), hWnd, iMsg, wParam,
lParam)
Call UnTrackMouseWheel(hWnd)
Exit Function

End Select

MouseWheelProc = CallWindowProc(GetProp(hWnd, OLDWNDPROC), hWnd, iMsg,
wParam, lParam)

Exit_Proc:
Exit Function


Err_Proc:
Err_Handler "Module2", "MouseWheelProc", Err.Description
Resume Exit_Proc


End Function


Public Function TrackMouseWheel(ByVal hWnd As Long) As Boolean


On Error GoTo Err_Proc
Dim lpfnOld As Long
Dim fSuccess As Boolean
On Error GoTo Out

If GetProp(hWnd, OLDWNDPROC) Then
TrackMouseWheel = True
Exit Function
End If

#If (DEBUGWINDOWPROC = 0) Then
lpfnOld = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf MouseWheelProc)

#Else
Dim objWPHook As WindowProcHook

Set objWPHook = CreateWindowProcHook
m_colWPHooks.Add objWPHook, CStr(hWnd)

With objWPHook
Call .SetMainProc(AddressOf MouseWheelProc)
lpfnOld = SetWindowLong(hWnd, GWL_WNDPROC, .ProcAddress)
Call .SetDebugProc(lpfnOld)
End With

#End If

If lpfnOld Then
fSuccess = SetProp(hWnd, OLDWNDPROC, lpfnOld)
End If

Out:
If fSuccess Then
TrackMouseWheel = True

Else
If lpfnOld Then Call SetWindowLong(hWnd, GWL_WNDPROC, lpfnOld)
'MsgBox "Error subclassing window &H" & Hex(hWnd) & vbCrLf & vbCrLf & _
' "Err# " & Err.Number & ": " & Err.Description,
vbExclamation
End If
Exit_Proc:
Exit Function


Err_Proc:
Err_Handler "Module2", "TrackMouseWheel", Err.Description
Resume Exit_Proc


End Function

Public Sub UnTrackMouseWheel(ByVal hWnd As Long)


On Error GoTo Err_Proc
Call SetWindowLong(hWnd, GWL_WNDPROC, GetProp(hWnd, OLDWNDPROC))
Call RemoveProp(hWnd, OLDWNDPROC)
Exit_Proc:
Exit Sub


Err_Proc:
Err_Handler "Module2", "UnTrackMouseWheel", Err.Description
Resume Exit_Proc


End Sub




"Hicham" <essirati@hotmail.com> wrote in message
news:ORH1uulcGHA.1208@TK2MSFTNGP02.phx.gbl...

Salut,
Qq1 peut me dire comment faire pour que la molette de la souris scrolle un
msflexgrid.
Merci.