Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,797
- Office Version
- 2016
- Platform
- Windows
Hi all,
Below is a code for scrolling all controls in a userform with the Mouse Wheel
Should work with Modal as well as with Modeless userforms .. Tested in 32Bit and 64Bit systems .. Also, the code doesn't use a Windows hook so it should be stable and safe.
See Workbook Demo
1- Code in a Standard Module :
2- Code in the UserForm Module:
Below is a code for scrolling all controls in a userform with the Mouse Wheel
Should work with Modal as well as with Modeless userforms .. Tested in 32Bit and 64Bit systems .. Also, the code doesn't use a Windows hook so it should be stable and safe.
See Workbook Demo
1- Code in a Standard Module :
Code:
Option Explicit
Public Enum CTRL_KEY_PRESS_STATE
Released
Pressed
End Enum
Public Enum WHEEL_ROTATION
Forward
Backward
End Enum
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type LongToInteger
Low As Integer
High As Integer
End Type
#If VBA7 Then
Private Type MSG
hwnd As LongPtr
message As Long
wParam As LongPtr
lParam As LongPtr
time As Long
pt As POINTAPI
End Type
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
Private Declare PtrSafe Function ClientToScreen Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function GetParent Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As LongPtr) As LongPtr
Private Declare PtrSafe Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wFlag As Long) As LongPtr
Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
Private Declare PtrSafe Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As LongPtr, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
Private Declare PtrSafe Function WaitMessage Lib "user32" () As Long
Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Private Declare PtrSafe Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" (dest As Any, ByVal numBytes As LongPtr)
Private Declare PtrSafe Function IsBadCodePtr Lib "kernel32" (ByVal lpfn As LongPtr) As Long
#If Win64 Then
Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal arg1 As LongPtr, ppacc As Any, pvarChild As Variant) As Long
#Else
Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
#End If
#Else
Private Type MSG
hwnd As Long
message As Long
wParam As Long
lParam As Long
time As Long
pt As POINTAPI
End Type
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 GetParent Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function WaitMessage Lib "user32" () As Long
Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function AccessibleObjectFromPoint Lib "Oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Sub ZeroMemory Lib "kernel32.dll" Alias "RtlZeroMemory" (Destination As Any, ByVal Length As Long)
Private Declare Function IsBadCodePtr Lib "kernel32" (ByVal lpfn As Long) As Long
#End If
Private Const CHILDID_SELF = &H0&
Private Const S_OK As Long = &H0
Private Const POINTSPERINCH As Long = 72
Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90
Private Const WM_MOUSEWHEEL = &H20A
Private Const PM_REMOVE = &H1
Private bCancelProcessing As Boolean
Private Const MK_CONTROL = &H8
Private Const SCROLL_CHANGE = 10
Private arObjCaptions() As Variant
Private arObjPointers() As Variant
Public Sub HookMouseWheelScroll(ByVal UF As Object)
Dim WheelRotation As WHEEL_ROTATION
Dim CtrlKey As CTRL_KEY_PRESS_STATE
Dim tMsg As MSG
Dim tCurPos As POINTAPI
Dim oIA As IAccessible
Dim oObjUnderMouse As Object
Dim oPage As Object
Dim oCtrl As Object
Dim vKid As Variant
Dim i As Long
Dim j As Long
Dim lResult As Long
Dim bCancel As Boolean
Static k As Long
#If VBA7 Then
Dim Ptr As LongPtr
#Else
Dim Ptr As Long
#End If
bCancelProcessing = False
k = 0
UF.Caption = UF.Caption & Chr(10)
j = 0
Erase arObjCaptions
Erase arObjPointers
For Each oCtrl In UF.Controls
If TypeName(oCtrl) = "MultiPage" Then
For Each oPage In oCtrl.Pages
i = i + 1
oPage.Caption = oPage.Caption & String(i, Chr(10))
ReDim Preserve arObjCaptions(j)
ReDim Preserve arObjPointers(j)
arObjCaptions(j) = oPage.Caption & Chr(10)
arObjPointers(j) = ObjPtr(oPage)
j = j + 1
Next
End If
Next
Do While Not bCancelProcessing
DoEvents
GetCursorPos tCurPos
#If Win64 Then
CopyMemory Ptr, tCurPos, LenB(tCurPos)
lResult = AccessibleObjectFromPoint(Ptr, oIA, vKid)
#Else
lResult = AccessibleObjectFromPoint(tCurPos.X, tCurPos.Y, oIA, vKid)
#End If
If lResult = S_OK Then
On Error Resume Next
Set oObjUnderMouse = objUnderMouse(UF, oIA, tCurPos)
If Not oObjUnderMouse Is Nothing Then
WaitMessage
If PeekMessage(tMsg, 0, WM_MOUSEWHEEL, WM_MOUSEWHEEL, PM_REMOVE) Then
CtrlKey = IIf(LoWord(CLng(tMsg.wParam)) = MK_CONTROL, Pressed, Released)
WheelRotation = IIf(tMsg.wParam > 0, Forward, Backward)
Call UF.OnScrollEvent(oObjUnderMouse, WheelRotation, CtrlKey, tMsg.pt.X, tMsg.pt.Y, bCancel)
If Not bCancel Then
If TypeName(oObjUnderMouse) = "TextBox" Then
With oObjUnderMouse
.SetFocus
If k = 0 Then
.SelStart = 0
Else
.SelStart = IIf(.SelStart = .LineCount, 0, .SelStart)
End If
If WheelRotation = Forward Then
.CurLine = .CurLine - 1
Else
.CurLine = IIf(.CurLine = .LineCount - 1, .CurLine, .CurLine + 1)
End If
End With
k = k + 1
End If
If TypeName(oObjUnderMouse) = "ScrollBar" Then
With oObjUnderMouse
If WheelRotation = Forward Then
.Value = IIf(.Value - oObjUnderMouse.SmallChange > .Min, .Value - oObjUnderMouse.SmallChange, .Min)
Else
.Value = IIf(.Value + oObjUnderMouse.SmallChange < .Max, .Value + oObjUnderMouse.SmallChange, .Max)
End If
End With
End If
If TypeName(oObjUnderMouse) = "ListBox" Or TypeName(oObjUnderMouse) = "ComboBox" Then
With oObjUnderMouse
If CtrlKey = Released Then
If WheelRotation = Forward Then
.TopIndex = .TopIndex - 1
Else
.TopIndex = .TopIndex + 1
End If
Else
.SetFocus
If WheelRotation = Forward Then
SendKeys "{LEFT}", True
DoEvents
SendKeys "{RIGHT}", True
Else
SendKeys "{RIGHT}", True
DoEvents
SendKeys "{RIGHT}", True
End If
End If
End With
End If
If TypeName(oObjUnderMouse) = UF.Name Or TypeName(oObjUnderMouse) = "Frame" Or TypeName(oObjUnderMouse) = "Page" Then
With oObjUnderMouse
If CtrlKey = Released Then
If WheelRotation = Forward Then
.ScrollTop = Application.Max(0, .ScrollTop - 5)
Else
.ScrollTop = Application.Min(.ScrollHeight - .InsideHeight, .ScrollTop + SCROLL_CHANGE)
End If
Else
If WheelRotation = Forward Then
.ScrollLeft = Application.Max(0, .ScrollLeft - 5)
Else
.ScrollLeft = Application.Min(.ScrollWidth - .InsideWidth, .ScrollLeft + SCROLL_CHANGE)
End If
End If
End With
End If
End If
DoEvents
End If
End If
End If
Loop
End Sub
Public Sub RemoveMouseWheelHook()
bCancelProcessing = True
End Sub
[B][COLOR=#008000]'Private Routines ..[/COLOR][/B]
[B][COLOR=#008000]'-------------------[/COLOR][/B]
Private Function objUnderMouse(ByVal UF As Object, ByVal oAcc As IAccessible, MouseLoc As POINTAPI) As Object
#If VBA7 Then
Dim lngPtr As LongPtr
Dim lObjPtr As LongPtr
Dim lCtrlPtr As LongPtr
Dim hwndForm As LongPtr
Dim hwndFromPoint As LongPtr
#Else
Dim lObjPtr As Long
Dim lCtrlPtr As Long
Dim hwndForm As Long
Dim hwndFromPoint As Long
#End If
Dim arCtrlsPosition() As Variant
Dim arCtrlsPointers() As Variant
Dim tPt As POINTAPI
Dim tRect As RECT
Dim oObj As Object
Dim oCtrl As Control
Dim sBuffer As String
Dim lCtrlLeft As Long
Dim lCtrlTop As Long
Dim lPos1 As Long
Dim lPos2 As Long
Dim lPos3 As Long
Dim lRet As Long
Dim i As Long
On Error Resume Next
hwndForm = FindWindow(vbNullString, UF.Caption)
For Each oCtrl In UF.Controls
ReDim Preserve arCtrlsPosition(i + 1)
ReDim Preserve arCtrlsPointers(i + 1)
tPt = GetRealCtrlScreenLocation(oCtrl, hwndForm, UF)
arCtrlsPosition(i) = tPt.X & tPt.Y
arCtrlsPointers(i) = ObjPtr(oCtrl)
arCtrlsPosition(i + 1) = tPt.X - 2 & tPt.Y - 1
arCtrlsPointers(i + 1) = ObjPtr(oCtrl)
i = i + 2
Next
lPos1 = WorksheetFunction.Match(oAcc.accName(CHILDID_SELF) & Chr(10), arObjCaptions, 0)
lObjPtr = WorksheetFunction.Index(arObjPointers, 1, lPos1)
Call oAcc.accLocation(lCtrlLeft, lCtrlTop, 0, 0, CHILDID_SELF)
lPos2 = WorksheetFunction.Match(lCtrlLeft & lCtrlTop, arCtrlsPosition, 0)
lCtrlPtr = WorksheetFunction.Index(arCtrlsPointers, 1, lPos2)
#If VBA7 Then
CopyMemory lngPtr, MouseLoc, LenB(MouseLoc)
hwndFromPoint = WindowFromPoint(lngPtr)
#Else
hwndFromPoint = WindowFromPoint(MouseLoc.X, MouseLoc.Y)
#End If
sBuffer = Space(256)
lRet = GetClassName(GetParent(hwndFromPoint), sBuffer, 256)
lPos3 = InStr(1, Left(sBuffer, lRet), "MdcPopup")
Select Case True
Case lPos3 <> 0
Set objUnderMouse = GetActiveComboBox(UF)
Exit Function
Case oAcc.accName(CHILDID_SELF) = UF.Caption
Set oObj = UF
Case lObjPtr = 0
If IsBadCodePtr(lCtrlPtr) = 0 Then
CopyMemory oObj, lCtrlPtr, 4
End If
Case lObjPtr <> 0
If IsBadCodePtr(lObjPtr) = 0 Then
CopyMemory oObj, lObjPtr, 4
End If
End Select
Set objUnderMouse = oObj
If Not oObj Is Nothing Then
ZeroMemory oObj, 4
End If
End Function
#If VBA7 Then
Private Function GetRealCtrlScreenLocation(ByVal Ctl As Object, ByVal hwnd As LongPtr, ByVal UF As Object) As POINTAPI
#Else
Private Function GetRealCtrlScreenLocation(ByVal Ctl As Object, ByVal hwnd As Long, ByVal UF As Object) As POINTAPI
#End If
Dim tRect As RECT
Dim tTopLeft As POINTAPI
Dim oMultiPage As Control
Dim oTempObj As Control
On Error Resume Next
Set oTempObj = Ctl.Parent
With tTopLeft
Select Case True
Case oTempObj Is Nothing
.X = PTtoPX(Ctl.Left - UF.ScrollLeft * UF.Zoom / 100, False)
.Y = PTtoPX(Ctl.Top - UF.ScrollTop * UF.Zoom / 100, True)
ClientToScreen hwnd, tTopLeft
Case TypeName(oTempObj) = "Frame"
GetWindowRect oTempObj.[_GethWnd], tRect
.X = PTtoPX(Ctl.Left - oTempObj.ScrollLeft * (oTempObj.Zoom / 100), False) + tRect.Left + 2
.Y = PTtoPX(Ctl.Top - oTempObj.ScrollTop * (oTempObj.Zoom / 100), True) + tRect.Top + 8
Case TypeName(oTempObj) = "Page"
Set oMultiPage = oTempObj.Parent
GetWindowRect GetNextWindow(oMultiPage.[_GethWnd], 5), tRect
.X = PTtoPX(Ctl.Left - oTempObj.ScrollLeft * (oTempObj.Zoom / 100), False) + tRect.Left
.Y = PTtoPX(Ctl.Top - oTempObj.ScrollTop * (oTempObj.Zoom / 100), True) + tRect.Top
Set oMultiPage = Nothing
End Select
End With
GetRealCtrlScreenLocation = tTopLeft
Set oTempObj = Nothing
End Function
Private Function GetActiveComboBox(ByVal Ctl As Object) As Control
Dim oCtl As Object
Dim lCur As Long
On Error Resume Next
For Each oCtl In Ctl.Controls
Err.Clear
lCur = oCtl.CurX
If Err.Number = 0 And TypeName(oCtl) = "ComboBox" Then Set GetActiveComboBox = oCtl: Exit Function
Next
End Function
Private Function LoWord(ByVal Word As Long) As Integer
Dim X As LongToInteger
CopyMemory X, Word, LenB(X)
LoWord = X.Low
End Function
Private Function ScreenDPI(ByVal bVert As Boolean) As Long
Static lDPI(1), lDC
If lDPI(0) = 0 Then
lDC = GetDC(0)
lDPI(0) = GetDeviceCaps(lDC, LOGPIXELSX)
lDPI(1) = GetDeviceCaps(lDC, LOGPIXELSY)
lDC = ReleaseDC(0, lDC)
End If
ScreenDPI = lDPI(Abs(bVert))
End Function
Private Function PTtoPX(ByVal Points As Single, ByVal bVert As Boolean) As Long
PTtoPX = Points * ScreenDPI(bVert) / POINTSPERINCH
End Function2- Code in the UserForm Module:
Code:
Option Explicit
Private Sub UserForm_Activate()
Dim i As Long
[B][COLOR=#008000]'Populate the controls[/COLOR][/B]
For i = 0 To 100
With ListBox1
.ColumnCount = 4
.ColumnWidths = "100;100;100;100"
.AddItem "COLUMN1"
.List(i, 1) = "COLUMN2"
.List(i, 2) = "COLUMN3"
.List(i, 3) = "COLUMN4"
End With
ListBox2.AddItem i
ComboBox1.AddItem i
ComboBox2.AddItem i
ComboBox3.AddItem i
ComboBox4.AddItem i
ComboBox5.AddItem i
ComboBox6.AddItem i
ComboBox7.AddItem i
ComboBox8.AddItem i
ComboBox9.AddItem i
Next i
With TextBox1
.Text = .Text & String(300, "A")
.Text = .Text & String(300, "I")
.Text = .Text & String(300, "X")
End With
Label1.Caption = "Object :"
Label2.Caption = "Wheel Rotation :"
Label3.Caption = "Scroll Direction :"
Label4.Caption = "Cursor X :"
Label5.Caption = "Cursor Y :"
Label6.Caption = "Scroll Cancelled :"
[B][COLOR=#008000]'Hook MouseWheel Scroll of Form and of all its controls[/COLOR][/B]
Call HookMouseWheelScroll(Me)
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Call RemoveMouseWheelHook
End Sub
Private Sub CommandButton1_Click()
Unload Me
End Sub
[B][COLOR=#008000]
'-------------------------[/COLOR][/B]
[B][COLOR=#008000]'Public Generic event[/COLOR][/B]
[B][COLOR=#008000]'-------------------------[/COLOR][/B]
Public Sub OnScrollEvent(ByVal Obj As Object, ByVal WheelRotation As WHEEL_ROTATION, _
ByVal CtrlKey As CTRL_KEY_PRESS_STATE, ByVal X As Long, ByVal Y As Long, Cancel As Boolean)
Dim sObjName As String, sWheelRot As String, sCtrlKey As String
Dim sCurX As String, sCurY As String, sCancelScrol As String
sObjName = "Object : (" & Obj.Name & ")"
sWheelRot = "Wheel Rotation : (" & IIf(WheelRotation = Forward, "Forward", "Backward") & ")"
sCtrlKey = "Scroll Direction : (" & IIf(CtrlKey = Released, "Vert", "Horiz") & ")"
sCurX = "Cursor X : (" & X & ")"
sCurY = "Cursor Y : (" & Y & ")"
sCancelScrol = "Scroll Cancelled : (" & Cancel & ")"
Label1.Caption = sObjName
Label2.Caption = sWheelRot
Label3.Caption = sCtrlKey
Label4.Caption = sCurX
Label5.Caption = sCurY
Label6.Caption = sCancelScrol
End Sub
