'nguon: suu tam
Private Type PointAPI
X As Long
Y As Long
End Type
Private Type MOUSEHOOKSTRUCT
pt As PointAPI
hwnd As Long
wHitTestCode As Long
dwExtraInfo As Long
End Type
#If VBA7 And Win64 Then 'Office 64-bit
Private Declare PtrSafe Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" (ByRef lpPoint As PointAPI) As Long
#Else ' Office 32-bit
Private Declare Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function GetCursorPos Lib "user32.dll" (ByRef lpPoint As PointAPI) As Long
#End If
'************************************************************************************
Private Const WH_MOUSE_LL As Long = 14
Private Const WM_MOUSEWHEEL As Long = &H20A
Private Const HC_ACTION As Long = 0
Private Const GWL_HINSTANCE As Long = (-6)
'************************************************************************************
Private mLngMouseHook As Long
Private mControlHwnd As Long
Private mbHook As Boolean
Private mCtl As Object
'************************************************************************************
Sub MouseMove(ByVal ctl As Object)
Dim lngAppInst As Long
Dim hwndUnderCursor As Long
Dim tPT As PointAPI
GetCursorPos tPT
hwndUnderCursor = WindowFromPoint(tPT.X, tPT.Y)
If mControlHwnd <> hwndUnderCursor Then
UnhookControlScroll
Set mCtl = ctl
mControlHwnd = hwndUnderCursor
lngAppInst = GetWindowLong(mControlHwnd, GWL_HINSTANCE)
If Not mbHook Then
mLngMouseHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0)
mbHook = mLngMouseHook <> 0
End If
End If
End Sub
'************************************************************************************
Sub UnhookControlScroll()
If mbHook Then
Set mCtl = Nothing
UnhookWindowsHookEx mLngMouseHook
mLngMouseHook = 0
mControlHwnd = 0
mbHook = False
End If
End Sub
'************************************************************************************
Private Function MouseProc(ByVal nCode As Long, ByVal wParam As Long, ByRef lParam As MOUSEHOOKSTRUCT) As Long
On Error GoTo ErrorHandler
Dim Index As Long
If (nCode = HC_ACTION) Then
If WindowFromPoint(lParam.pt.X, lParam.pt.Y) = mControlHwnd Then
If wParam = WM_MOUSEWHEEL Then
MouseProc = True
If lParam.hwnd > 0 Then
Index = -1
Else
Index = 1
End If
Index = Index + mCtl.TopIndex
If Index >= 0 Then
mCtl.TopIndex = Index
End If
Exit Function
End If
Else
UnhookControlScroll
End If
End If
MouseProc = CallNextHookEx(mLngMouseHook, nCode, wParam, ByVal lParam)
Exit Function
ErrorHandler:
UnhookControlScroll
End Function
