Option Explicit
Implements IPrivateMembers
Private WithEvents oTextBox As MSForms.TextBox
Private WithEvents oCmndBars As CommandBars
Public Event ScrollEvent( _
ByVal TextBox As MSForms.TextBox, _
ByVal ScrollLines As Long, _
ByVal ScrollDirection As SROLL_DIRECTION, _
ByVal Rotations As Long, _
ByVal CtrlShiftKeys As KEYS_STATUS, _
ByVal X As Single, _
ByVal Y As Single, _
ByRef Cancel As Boolean _
)
Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As LongPtr) As LongPtr
Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal arg1 As LongPtr, ppacc As Any, pvarChild As Variant) As Long
#Else
Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal X As Long, ByVal Y As Long, ppacc As Any, pvarChild As Variant) As Long
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Private Declare PtrSafe Function IsBadCodePtr Lib "kernel32" (ByVal lpfn As LongPtr) As Long
Private Declare PtrSafe Function CoLockObjectExternal Lib "OLE32.DLL" (ByVal pUnk As IUnknown, ByVal fLock As Boolean, Optional ByVal fLastUnlockReleases As Boolean) As Long
Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As LongPtr) As Long
Private Declare PtrSafe Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function GetAncestor Lib "user32" (ByVal hUf As LongPtr, ByVal gaFlags As Long) As LongPtr
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 SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
Private Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
Private Declare PtrSafe Function SendInput Lib "user32.dll" (ByVal nInputs As Long, pInputs As Any, ByVal cbSize As Long) As Long
Private Declare PtrSafe Function SetCursorPos Lib "user32.dll" (ByVal X As Long, ByVal Y As Long) As Long
Private Declare PtrSafe Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function EqualRect Lib "user32" (lpRect1 As RECT, lpRect2 As RECT) As Long
#Else
Private Enum LongPtr
[_]
End Enum
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
Private Declare Function AccessibleObjectFromPoint Lib "oleacc" (ByVal X As Long, ByVal Y As Long, ppacc As Any, pvarChild As Variant) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Private Declare Function IsBadCodePtr Lib "kernel32" (ByVal lpfn As LongPtr) As Long
Private Declare Function CoLockObjectExternal Lib "OLE32.DLL" (ByVal pUnk As IUnknown, ByVal fLock As Boolean, Optional ByVal fLastUnlockReleases As Boolean) As Long
Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUF As LongPtr) As Long
Private Declare Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare Function GetAncestor Lib "user32" (ByVal hUf As LongPtr, ByVal gaFlags As Long) As LongPtr
Private Declare 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 Function WaitMessage Lib "user32" () As Long
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
Private Declare Function SendInput Lib "user32.dll" (ByVal nInputs As Long, pInputs As Any, ByVal cbSize As Long) As Long
Private Declare Function SetCursorPos Lib "user32.dll" (ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long
Private Declare Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
Private Declare Function EqualRect Lib "user32" (lpRect1 As RECT, lpRect2 As RECT) As Long
Public Enum SROLL_DIRECTION
Forward
Backward
End Enum
Public Enum KEYS_STATUS
None
Ctrl
Shift
Ctrl_Shift
End Enum
Private Const NULL_PTR = 0^
Private Const PTR_SIZE = 8&
#Else
Private Const NULL_PTR = 0&
Private Const PTR_SIZE = 4&
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 Msg
hwnd As LongPtr
message As Long
wParam As LongPtr
lParam As LongPtr
time As Long
pt As POINTAPI
End Type
Private Type TAG_MOUSEINPUT
dx As Long
dy As Long
mouseData As Long
dwFlags As Long
time As Long
dwExtraInfo As LongPtr
End Type
Private Type MOUSE_INPUT
type As Long
mi As TAG_MOUSEINPUT
End Type
Private oForm As Object
Private bMouseOverControl As Boolean
Private nScrollLines As Long
Private XCord As Single, YCord As Single
Public Sub Init(ByVal Form As Object)
Dim hwnd As LongPtr
If IsMouseWheelEnabled Then MsgBox "MouseWheel Scrolling already enabled!": Exit Sub
Call IUnknown_GetWindow(Form, VarPtr(hwnd))
Set oForm = Form
SetProp Application.hwnd, "Hwnd", hwnd
SetProp GetProp(Application.hwnd, "Hwnd"), "Enabled", 1&
End Sub
Public Sub EnableMouseWheelScroll(ByVal TextBoxesArray As Variant, ByVal ScrollLinesArray As Variant)
Dim oMouseWheel As CWheelScroll
Dim IProperties As IPrivateMembers
Dim i As Long
If TypeName(TextBoxesArray) = "TextBox" Then
Set oForm = GetUserForm(TextBoxesArray)
SetProp GetProp(Application.hwnd, "Hwnd"), "TextBoxesCount", GetProp(GetProp(Application.hwnd, "Hwnd"), "TextBoxesCount") + 1
End If
If IsArray(TextBoxesArray) And IsArray(ScrollLinesArray) Then
If UBound(TextBoxesArray) <> UBound(ScrollLinesArray) Then
Call DisableMouseWheelScroll
MsgBox "TextBoxes and ScrollLines arrays must be identical in their lengths.", , "Error"
Exit Sub
End If
For i = LBound(TextBoxesArray) To UBound(TextBoxesArray)
SetProp GetProp(Application.hwnd, "Hwnd"), "Hwnd", 1&
Set oMouseWheel = New CWheelScroll
Call CoLockObjectExternal(oMouseWheel, True)
Set IProperties = oMouseWheel
IProperties.ScrollLines = ScrollLinesArray(i)
Set IProperties.TextBox = TextBoxesArray(i)
IProperties.ScrollLines = ScrollLinesArray(i)
Set IProperties.TextBox = TextBoxesArray(i)
oMouseWheel.EnableMouseWheelScroll TextBoxesArray(i), ScrollLinesArray(i)
SetProp GetProp(Application.hwnd, "Hwnd"), "Tag" & i, ObjPtr(oMouseWheel)
Next i
End If
Set oCmndBars = Application.CommandBars
Call oCmndBars_OnUpdate
End Sub
Public Property Get IsMouseWheelEnabled() As Boolean
IsMouseWheelEnabled = (GetProp(GetProp(Application.hwnd, "Hwnd"), "Enabled"))
End Property
Public Sub DisableMouseWheelScroll()
Dim oTemp As Object
Dim lProp As LongPtr, i As Long
Application.DisplayFullScreen = Application.DisplayFullScreen
If IsMouseWheelEnabled = False Then MsgBox "MouseWheel Scrolling already disabled!": Exit Sub
If GetProp(Application.hwnd, "Hwnd") Then
For i = 0& To CLng(GetProp(GetProp(Application.hwnd, "Hwnd"), "TextBoxesCount"))
lProp = GetProp(GetProp(Application.hwnd, "Hwnd"), "Tag" & i)
If lProp And IsBadCodePtr(lProp) = 0& Then
CopyMemory oTemp, lProp, PTR_SIZE
Call CoLockObjectExternal(oTemp, False)
CopyMemory oTemp, 0&, PTR_SIZE
Set oTemp = Nothing
RemoveProp GetProp(Application.hwnd, "Hwnd"), GetProp(GetProp(Application.hwnd, "Hwnd"), "Tag" & i)
End If
Next i
Call CoLockObjectExternal(Me, False)
RemoveProp GetProp(Application.hwnd, "Hwnd"), "TextBoxesCount"
RemoveProp GetProp(Application.hwnd, "Hwnd"), "Enabled"
RemoveProp Application.hwnd, "Hwnd"
End If
End Sub
nScrollLines = RHS
End Property
Private Property Set IPrivateMembers_TextBox(ByVal RHS As MSForms.IMdcText)
Set oTextBox = RHS
End Property
Private Sub Class_Terminate()
If Not oTextBox Is Nothing Then
Debug.Print ObjPtr(oTextBox), "Memory properly released."
End If
End Sub
Private Sub oTextBox_MouseMove( _
ByVal Button As Integer, _
ByVal Shift As Integer, _
ByVal X As Single, _
ByVal Y As Single _
)
XCord = X: YCord = Y
If bMouseOverControl Then Exit Sub
bMouseOverControl = True
Call MonitorMouseWheel(oTextBox)
bMouseOverControl = False
End Sub
Private Sub MonitorMouseWheel(ByVal TextBox As MSForms.TextBox)
Const WHEEL_DELTA = 120&, MK_CONTROL = &H8, MK_SHIFT = &H4
Const WM_MOUSEWHEEL = &H20A, SPI_GETWHEELSCROLLLINES = &H68
Const PM_NOREMOVE = &H0, SM_CXHTHUMB = 10&, GA_ROOT = 2&
Dim nDelta As Long, nVKey As Long
#Else
Dim nDelta As Integer, nVKey As Integer
Dim bCancel As Boolean
Dim eScrollDirection As SROLL_DIRECTION
Dim eKeys As KEYS_STATUS
Dim lScrollBarWidth As Long, lRotations As Long
Dim lAccumulatedDelta As Currency
Dim tMsg As Msg
Dim uRect As RECT, R1 As RECT, R2 As RECT
Dim uP1 As POINTAPI, uP2 As POINTAPI
Dim iAcc As IAccessible
On Error Resume Next
Application.EnableCancelKey = xlDisabled
R1 = GetControlRect
Do
If oForm Is Nothing Then Exit Do
Set oForm.MouseWheel = Me
R2 = GetControlRect
If EqualRect(R1, R2) = 0& Then Exit Do
WaitMessage
If PeekMessage(tMsg, NULL_PTR, WM_MOUSEWHEEL, WM_MOUSEWHEEL, PM_NOREMOVE) Then
nDelta = HiWord64(tMsg.wParam): nVKey = LoWord64(tMsg.wParam)
#Else
nDelta = HiWord32(tMsg.wParam): nVKey = LoWord32(tMsg.wParam)
If nDelta * lAccumulatedDelta > 0& Then
lAccumulatedDelta = lAccumulatedDelta + nDelta
Else
lAccumulatedDelta = nDelta
End If
If nScrollLines <= 0& Then
If SystemParametersInfo(SPI_GETWHEELSCROLLLINES, 0&, nScrollLines, 0&) = 0& Then
nScrollLines = 3&
End If
End If
lRotations = lAccumulatedDelta \ nDelta
lRotations = IIf(lAccumulatedDelta > 0&, lRotations, -(lRotations))
eScrollDirection = IIf(lRotations > 0&, Forward, Backward)
If (nVKey And (MK_CONTROL Or MK_SHIFT)) = (MK_CONTROL Or MK_SHIFT) Then
eKeys = Ctrl_Shift
ElseIf nVKey And MK_SHIFT Then
eKeys = Shift
ElseIf nVKey And MK_CONTROL Then
eKeys = Ctrl
Else
eKeys = None
End If
RaiseEvent ScrollEvent( _
oTextBox, _
nScrollLines, _
eScrollDirection, _
lRotations, _
eKeys, _
XCord, _
YCord, _
bCancel _
)
If bCancel = False Then
Set iAcc = TextBox
lScrollBarWidth = GetSystemMetrics(SM_CXHTHUMB)
With uRect
iAcc.accLocation .Left, .Top, .Right, .Bottom
.Left = .Right + .Left - lScrollBarWidth
.Right = .Left + lScrollBarWidth
.Bottom = .Bottom + .Top
End With
With uRect
uP1.X = .Left + 5&: uP1.Y = .Top + lScrollBarWidth / 2&
uP2.X = .Right - lScrollBarWidth + 5&: uP2.Y = .Bottom - lScrollBarWidth + 5&
End With
If eScrollDirection = Forward Then
If GetAncestor(WndFromPoint(uP1.X, uP1.Y), GA_ROOT) = GetProp(Application.hwnd, "Hwnd") Then
Call ClickAtPosition(uP1.X, uP1.Y, nScrollLines)
End If
Else
If GetAncestor(WndFromPoint(uP2.X, uP2.Y), GA_ROOT) = GetProp(Application.hwnd, "Hwnd") Then
Call ClickAtPosition(uP2.X, uP2.Y, nScrollLines)
End If
End If
End If
End If
DoEvents
Loop
End Sub
Private Sub ClickAtPosition(ByVal X As Long, ByVal Y As Long, Optional ByVal ScrollLines As Long = 1&)
Const MOUSEEVENTF_LEFTDOWN = &H2, MOUSEEVENTF_LEFTUP = &H4
ReDim uInput(2&) As MOUSE_INPUT
Dim uCurPos As POINTAPI, i As Long
GetCursorPos uCurPos
ShowCursor 0&
SetCursorPos X, Y
For i = 0& To ScrollLines - 1&
With uInput(0&)
.type = 0&
.mi.dx = X
.mi.dy = Y
.mi.mouseData = 0&
.mi.dwFlags = MOUSEEVENTF_LEFTDOWN
End With
With uInput(1&)
.type = 0&
.mi.dx = X
.mi.dy = Y
.mi.mouseData = 0&
.mi.dwFlags = MOUSEEVENTF_LEFTUP
End With
Call SendInput(2&, uInput(0&), LenB(uInput(0&)))
Next i
SetCursorPos uCurPos.X, uCurPos.Y
ShowCursor -1&
End Sub
Private Function GetUserForm(ByVal Ctrl As MSForms.Control) As Object
Dim oTmp As Object
Set oTmp = Ctrl.Parent
Do While TypeOf oTmp Is MSForms.Control
Set oTmp = oTmp.Parent
Loop
Set GetUserForm = oTmp
End Function
Private Function GetControlRect() As RECT
Dim tCurPos As POINTAPI, iAcc As IAccessible
Call GetCursorPos(tCurPos)
Dim lPt2 As LongLong
Call CopyMemory(lPt2, tCurPos, LenB(tCurPos))
Call AccessibleObjectFromPoint(lPt2, iAcc, 0&)
#Else
Call AccessibleObjectFromPoint(tCurPos.X, tCurPos.Y, iAcc, 0&)
With GetControlRect
iAcc.accLocation .Left, .Top, .Right, .Bottom
End With
End Function
Private Function WndFromPoint(ByVal X As Long, ByVal Y As Long) As LongPtr
Dim tPt As POINTAPI
tPt.X = X: tPt.Y = Y
Dim Ptr As LongLong
Call CopyMemory(Ptr, tPt, LenB(tPt))
WndFromPoint = WindowFromPoint(Ptr)
#Else
WndFromPoint = WindowFromPoint(tPt.X, tPt.Y)
End Function
Private Sub oCmndBars_OnUpdate()
If IsWindow(GetProp(Application.hwnd, "Hwnd")) = 0 Then
Set oCmndBars = Nothing
Set oForm = Nothing
Call CoLockObjectExternal(Me, False)
End If
End Sub
Private Function HiWord64(ByVal DWord As LongPtr) As Long
CopyMemory HiWord64, ByVal VarPtr(DWord) + 2&, 4&
End Function
Private Function LoWord64(ByVal DWord As LongPtr) As Long
CopyMemory LoWord64, DWord, 4&
End Function
Private Function HiWord32(ByVal Word As Long) As Integer
CopyMemory HiWord32, ByVal VarPtr(Word) + 2&, 2&
End Function
Private Function LoWord32(ByVal Word As Long) As Integer
CopyMemory LoWord32, Word, 2&
End Function
