Hello All
I have seen some code around that allows scrolling in listboxes using the mousewheel. I have also seen some code here on the forums about scrolling through a combobox embedded in a workbook. I have tried adapting both of these to suit a combobox on a userform but I cannot get either to work.
Here is the code that I used for the embedded combobox; I added it to the base code for the userform
I then added the following code to a standard module as stated in the forum post;
In the first section of the code there is a msgbox that never gets shown so I don't think code is recognizing the mouse wheel at all.
The second set of code that I used was set up to work with a listbox and it works perfectly with a listbox control. The problem is I cannot adapt it to suit a combobox and if I use a breakpoint to see what is happening Excel freezes.
The following code is added to the userforms code;
Then in a standard module I added the following code;
I added this section of the code;
I think this should only work on a Combobox but a Combobox does not appear to support the TopIndex value. Is there a way this can be setup to work with a userform combobox?
Sorry about the huge amount of code.
Thanks in advance
Phil
I have seen some code around that allows scrolling in listboxes using the mousewheel. I have also seen some code here on the forums about scrolling through a combobox embedded in a workbook. I have tried adapting both of these to suit a combobox on a userform but I cannot get either to work.
Here is the code that I used for the embedded combobox; I added it to the base code for the userform
Rich (BB code):
Private Sub ComboBox1_GotFocus()
'Store the first TopIndex Value
intTopIndex = ComboBox1.TopIndex
Hook_Mouse
End Sub
Private Sub ComboBox1_LostFocus()
UnHook_Mouse
End SubI then added the following code to a standard module as stated in the forum post;
Rich (BB code):
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
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
Dim hhkLowLevelMouse, lngInitialColor As Long
Dim udtlParamStuct As MSLLHOOKSTRUCT
Public intTopIndex As Integer
'==========================================================================
'\\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 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
ComboBox1.TopLeftCell.Select
UnHook_Mouse
Exit Function
End If
If (nCode = HC_ACTION) Then
If wParam = WM_MOUSEWHEEL Then
'\\ Don't process Default WM_MOUSEWHEEL Window message
LowLevelMouseProc = True
'\\ Change Sheet&\DropDown names as required
With 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
Exit Function
End If
LowLevelMouseProc = CallNextHookEx(0, nCode, wParam, ByVal lParam)
End Function
'=======================================================================
Sub Hook_Mouse()
hhkLowLevelMouse = SetWindowsHookEx _
(WH_MOUSE_LL, AddressOf LowLevelMouseProc, Application.Hinstance, 0)
End Sub
'========================================================================
Sub UnHook_Mouse()
If hhkLowLevelMouse <> 0 Then UnhookWindowsHookEx hhkLowLevelMouse
End SubIn the first section of the code there is a msgbox that never gets shown so I don't think code is recognizing the mouse wheel at all.
The second set of code that I used was set up to work with a listbox and it works perfectly with a listbox control. The problem is I cannot adapt it to suit a combobox and if I use a breakpoint to see what is happening Excel freezes.
The following code is added to the userforms code;
Rich (BB code):
Private Sub UserForm_Initialize()
HookWheel Me, Me.Width, Me.Height, 3
End Sub
Private Sub UserForm_Terminate()
UnHookWheel
End SubThen in a standard module I added the following code;
Rich (BB code):
Option Explicit
Option Private Module
'************************************************************
'APIs
'************************************************************
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 Declare Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As typeRect) As Long
'used to store screen position for GetWindowRect call
Private Type typeRect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'screen factor constants
Private dXFactor As Double 'hold screen Conversion coordinates
Private dYFactor As Double
Private lCaptionHeight As Long
'************************************************************
'Constants
'************************************************************
Private Const GWL_WNDPROC = -4
Private Const WM_MOUSEWHEEL = &H20A
Private Const SM_MOUSEWHEELPRESENT = 75
Private lLines As Long
'************************************************************
'Variables
'************************************************************
Private hForm As Long
Public lPrevWndProc As Long
Private lX As Long
Private lY As Long
Private bUp As Boolean
Private frmContainer As msForms.UserForm
'*************************************************************
'WindowProc
'*************************************************************
Private Function WindowProc(ByVal lWnd As Long, ByVal lMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'converted from code by Kevin Wilson on thevbzone
'Test if the message is WM_MOUSEWHEEL
If lMsg = WM_MOUSEWHEEL Then
lX = lParam And 65535
lY = lParam \ 65535
bUp = (wParam > 0)
WheelHandler bUp
End If
'Sends message to previous procedure if not MOUSEWHEEL
'This is VERY IMPORTANT!!!
If lMsg <> WM_MOUSEWHEEL Then
WindowProc = CallWindowProc(lPrevWndProc, lWnd, lMsg, wParam, lParam)
End If
End Function
Public Sub HookWheel(ByVal frmName As msForms.UserForm, dWidth As Double, dHeight As Double, ByVal lLinesToScroll As Long)
If WheelPresent Then
Set frmContainer = frmName
hForm = GetFormHandle(frmName)
GetScreenFactors hForm, dWidth, dHeight
lLines = lLinesToScroll
'create the call back procedure
'addressof doesn't work in earlier versions but not sure which ones
lPrevWndProc = SetWindowLong(hForm, GWL_WNDPROC, AddressOf WindowProc)
End If
End Sub
Public Sub UnHookWheel()
'very important that this is called when the form is unloaded to remove the call back
Call SetWindowLong(hForm, GWL_WNDPROC, lPrevWndProc)
End Sub
Private Function GetFormHandle(ByVal frmName As msForms.UserForm, Optional bByClass As Boolean = True) As Long
'returns a handle to the userform
Dim strClassName As String
Dim strCaption As String
strClassName = IIf(Val(Application.Version) > 8, "ThunderDFrame", "ThunderXFrame") & vbNullChar
strCaption = vbNullString
GetFormHandle = FindWindowA(strClassName, strCaption)
End Function
Public Sub GetScreenFactors(lHwnd As Long, dWidth As Double, dHeight As Double)
'returns screen factors for conversion to Excel units rather than win coords
Dim uRect As typeRect
GetWindowRect lHwnd, uRect
dXFactor = dWidth / (uRect.Right - uRect.Left)
dYFactor = dHeight / (uRect.Bottom - uRect.Top)
lCaptionHeight = dHeight - frmContainer.InsideHeight
End Sub
Private Function WheelPresent() As Boolean
'function by Kevin Wilson from www.thevbzone.com
'Check for wheel mouse on Win98, WinNT 4.0, & Win2000
If GetSystemMetrics(SM_MOUSEWHEELPRESENT) Then
WheelPresent = True
' Check for wheel mouse on Win32's, Win95, & WinNT 3.5x
ElseIf FindWindowA("MouseZ", "Magellan MSWHEEL") <> 0 Then
WheelPresent = True
End If
End Function
Public Sub WheelHandler(bUp As Boolean)
Dim ctlFocus As msForms.Control
Dim ctlName As msForms.Control
Dim lTopIndex As Long
Dim bMultiPage As Boolean
Dim lPage As Long
Dim lMove As Long
If Not IsOverForm Then Exit Sub
Set ctlFocus = frmContainer.ActiveControl
'if we are in a multipage then need to set the control
'to whatever the subcontrol is on the active page
If TypeOf ctlFocus Is msForms.MultiPage Then
'set the multipage flag
bMultiPage = True
'store the page number for the MP
lPage = ctlFocus.Value
'set the focus control to the control on the current page
Set ctlFocus = ctlFocus.SelectedItem.ActiveControl
End If
'convert screen coords
lX = lX * dXFactor
lY = lY * dYFactor
lY = lY - lCaptionHeight
'for anything but a commandbutton and textbox lx is relative to the left
'and top of the control, so adjust
If Not (TypeOf ctlFocus Is msForms.CommandButton Or TypeOf ctlFocus Is msForms.TextBox) Then
'lX = lX + ctlFocus.Left
'lY = lY + ctlFocus.Top
End If
'loop controls, looking for list boxes
For Each ctlName In frmContainer.Controls
With ctlName
If TypeOf ctlName Is msForms.ListBox Then
'if we are in a multipage
If bMultiPage = True Then
'if we are not on the correct page then skip this control
If lPage <> .Parent.Index Then GoTo SkipControl
End If
'check right of left bound
If lX > .Left Then
'check within width
If lX < .Left + .Width Then
'check below top bound
If lY > .Top Then
'check within height
If lY < .Top + .Height Then
'WE FOUND THE RIGHT CONTROL SO HANDLE THE SCROLL
'if the list is empty there is nothing to scroll
If .ListCount = 0 Then Exit Sub
'check scroll direction
lMove = IIf(bUp, -lLines, lLines)
'get the new top index
lTopIndex = .TopIndex + lMove
'check it is within valid limits
If lTopIndex < 0 Then
lTopIndex = 0
ElseIf lTopIndex > .ListCount - (.Height / 10) + 2 Then
lTopIndex = .TopIndex
End If
'set the new top index
.TopIndex = lTopIndex
'scroll has been handled so stop looping
Exit Sub
End If
End If
End If
End If
End If
If TypeOf ctlName Is msForms.ComboBox Then
'if we are in a multipage
If bMultiPage = True Then
'if we are not on the correct page then skip this control
If lPage <> .Parent.Index Then GoTo SkipControl
End If
'check right of left bound
If lX > .Left Then
'check within width
If lX < .Left + .Width Then
'check below top bound
If lY > .Top Then
'check within height
If lY < .Top + .Height Then
'WE FOUND THE RIGHT CONTROL SO HANDLE THE SCROLL
'if the list is empty there is nothing to scroll
If .ListCount = 0 Then Exit Sub
'check scroll direction
lMove = IIf(bUp, -lLines, lLines)
'get the new top index
lTopIndex = .TopIndex + lMove
'check it is within valid limits
If lTopIndex < 0 Then
lTopIndex = 0
ElseIf lTopIndex > .ListCount - (.Height / 10) + 2 Then
lTopIndex = .TopIndex
End If
'set the new top index
.TopIndex = lTopIndex
'scroll has been handled so stop looping
Exit Sub
End If
End If
End If
End If
End If
End With
SkipControl:
Next ctlName
End Sub
Public Function IsOverForm() As Boolean
'we can't get the form's coordinates directly when referenced as a form
'rather than ME within the form's code
'so call GetWindowRect again in case the form has been moved
Dim uRect As typeRect
GetWindowRect hForm, uRect
With uRect
If lX >= .Left Then
If lX <= .Right Then
If lY >= .Top Then
If lY <= .Bottom Then
IsOverForm = True
lX = lX - .Left
lY = lY - .Top
End If
End If
End If
End If
End With
End FunctionI added this section of the code;
Rich (BB code):
If TypeOf ctlName Is msForms.ComboBox Then
'if we are in a multipage
If bMultiPage = True Then
'if we are not on the correct page then skip this control
If lPage <> .Parent.Index Then GoTo SkipControl
End If
'check right of left bound
If lX > .Left Then
'check within width
If lX < .Left + .Width Then
'check below top bound
If lY > .Top Then
'check within height
If lY < .Top + .Height Then
'WE FOUND THE RIGHT CONTROL SO HANDLE THE SCROLL
'if the list is empty there is nothing to scroll
If .ListCount = 0 Then Exit Sub
'check scroll direction
lMove = IIf(bUp, -lLines, lLines)
'get the new top index
lTopIndex = .TopIndex + lMove
'check it is within valid limits
If lTopIndex < 0 Then
lTopIndex = 0
ElseIf lTopIndex > .ListCount - (.Height / 10) + 2 Then
lTopIndex = .TopIndex
End If
'set the new top index
.TopIndex = lTopIndex
'scroll has been handled so stop looping
Exit Sub
End If
End If
End If
End If
End IfI think this should only work on a Combobox but a Combobox does not appear to support the TopIndex value. Is there a way this can be setup to work with a userform combobox?
Sorry about the huge amount of code.
Thanks in advance
Phil
