How do I scroll a list in Excel?
Option Explicit
Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function GetForegroundWindow Lib "user32" () As Long
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
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
Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, _
ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "user32" ( _
ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" ( _
ByVal hwnd As Long, ByVal hDC As Long) As Long
Type POINTAPI
X As Long
Y As Long
End Type
Type MSLLHOOKSTRUCT 'Will Hold the lParam struct Data
pt As POINTAPI
mouseData As Long ' Holds Forward\Bacward flag
flags As Long
time As Long
dwExtraInfo As Long
End Type
Const HC_ACTION = 0
Const WH_MOUSE_LL = 14
Const WM_MOUSEWHEEL = &H20A
Const LOGPIXELSX As Long = 88
Const LOGPIXELSY As Long = 90
Const PointsPerInch = 72
Dim hhkLowLevelMouse, lngInitialColor As Long
Dim udtlParamStuct As MSLLHOOKSTRUCT
Dim udtCursorPos As POINTAPI
Dim lnghDC As Long
Dim dblPixelsPerPointsX, dblPixelsPerPointsY, dblZoomPercentage As Double
Public objTargetShape As Object
Public objLastCell As Range
Public intTopIndex As Integer
'==========================================================================
'\\ Call Back Procedure====================================================
'===========================================================================
Function LowLevelMouseProc _
(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'Avoid XL crashing if RunTime error occurs due to Mouse fast movement
On Error Resume Next
' \\ Unhook & get out in case the application is deactivated
If GetForegroundWindow <> FindWindow("XLMAIN", Application.Caption) Then
Sheets("Sheet1").ComboBox1.TopLeftCell.Select
UnHook_Mouse
Exit Function
End If
If (nCode = HC_ACTION) Then
If wParam = WM_MOUSEWHEEL Then
'\\ Get the current Mouse XY coordonates
GetCursorPos udtCursorPos
'\\Check if Mouse is within the combo rectangle
With udtCursorPos
If (.X < LocationPoint(objTargetShape, "TopLeft").X) Or _
(.X > LocationPoint(objTargetShape, "TopRight").X) Or _
.Y < LocationPoint(objTargetShape, "TopLeft").Y _
Or .Y > LocationPoint(objTargetShape, "BottomLeft").Y + 136 Then
'if Cursor Outside combo do nothing
objLastCell.Activate
Else
'\\ else customise Mouse Wheel behaviour
With Sheets("Sheet1").ComboBox1
'\\ if rolling forward increase Top index by 1 to cause an Up Scroll
If GetHookStruct(lParam).mouseData > 0 Then
.TopIndex = intTopIndex - 1
'\\ Store new TopIndex value
intTopIndex = .TopIndex
Else '\\ if rolling backward decrease Top index by 1 to cause _
'\\a Down Scroll
.TopIndex = intTopIndex + 1
'\\ Store new TopIndex value
intTopIndex = .TopIndex
End If
End With
End If
End With
End If
End If
LowLevelMouseProc = CallNextHookEx(0, nCode, wParam, ByVal lParam)
End Function
'======================================================================
'\\ Supporting Functions================================================
'=======================================================================
'\\Copy the Data from lParam of the Hook Procedure argument to our Struct
Function GetHookStruct(ByVal lParam As Long) As MSLLHOOKSTRUCT
CopyMemory VarPtr(udtlParamStuct), lParam, LenB(udtlParamStuct)
GetHookStruct = udtlParamStuct
End Function
'\\ Function to get the metrics of the Combo
Function LocationPoint(Shp As Object, Border As String) As POINTAPI
lnghDC = GetDC(0)
Dim X, Y As Long
'\\ Get current screen Pixels per points + current Zoom
dblPixelsPerPointsX = GetDeviceCaps(lnghDC, LOGPIXELSX) / PointsPerInch
dblPixelsPerPointsY = GetDeviceCaps(lnghDC, LOGPIXELSY) / PointsPerInch
dblZoomPercentage = (ActiveWindow.Zoom / 100)
'\\ Determine the exact coordinates of the shape's edges in Pixels
Select Case Border
Case Is = "TopLeft"
X = ActiveWindow.PointsToScreenPixelsX(Shp.Left * _
(dblPixelsPerPointsX * dblZoomPercentage))
Y = ActiveWindow.PointsToScreenPixelsY(Shp.Top * _
(dblPixelsPerPointsY * dblZoomPercentage))
Case Is = "TopRight"
X = ActiveWindow.PointsToScreenPixelsX((Shp.Left + Shp.Width) * _
(dblPixelsPerPointsX * dblZoomPercentage))
Y = ActiveWindow.PointsToScreenPixelsY(Shp.Top * _
(dblPixelsPerPointsY * dblZoomPercentage))
Case Is = "BottomLeft"
X = ActiveWindow.PointsToScreenPixelsX(Shp.Left * _
(dblPixelsPerPointsX * dblZoomPercentage))
Y = ActiveWindow.PointsToScreenPixelsY((Shp.Top + Shp.Height) * _
(dblPixelsPerPointsY * dblZoomPercentage))
Case Is = "BottomRight"
X = ActiveWindow.PointsToScreenPixelsX((Shp.Left + Shp.Width) * _
(dblPixelsPerPointsX * dblZoomPercentage))
Y = ActiveWindow.PointsToScreenPixelsY((Shp.Top + Shp.Height) * _
(dblPixelsPerPointsY * dblZoomPercentage))
Case Else
MsgBox "error": Exit Function
End Select
With LocationPoint
.X = X
.Y = Y
End With
ReleaseDC 0, lnghDC
End Function
'==================================================================
'\\ Hooking & UnHooking Procedures=================================
'triggered upon the combo respectively getting and loosing focus==
'=================================================================
Public Sub Hook_Mouse()
hhkLowLevelMouse = SetWindowsHookEx _
(WH_MOUSE_LL, AddressOf LowLevelMouseProc, Application.Hinstance, 0)
End Sub
Public Sub UnHook_Mouse()
If hhkLowLevelMouse <> 0 Then UnhookWindowsHookEx hhkLowLevelMouse
End Sub