Hello: I found this amazing code from Peter Thorton to make listbox's and combobox's scrollable. I am using Excel 2016 and it works fine on my combobox's that sit directly on a form, however it does not work for my combobox's that sit on a frame on the form. I thought it would be quite simple to adapt the code to work for these combobox's, but have been unsuccessful. Can someone please advise me how I would adapt my code so that the combobox's sitting in a frame on a form are also scrollable. Any assistance is greatly appreciated!
Peter's Code:
OK, now I know which code worked for you. Could you also clarify if you tried the code you found, which as written didn't work, but with the corrections I suggested.
The following should scroll both ComboBox and ListBox controls with the mouse wheel.
Put one ComboBox and two ListBox's on a form. Paste the following into the Userform module and a Normal module as indicated
You can delete the commented PostMessage code
Peter Thornton
Peter's Code:
OK, now I know which code worked for you. Could you also clarify if you tried the code you found, which as written didn't work, but with the corrections I suggested.
The following should scroll both ComboBox and ListBox controls with the mouse wheel.
Put one ComboBox and two ListBox's on a form. Paste the following into the Userform module and a Normal module as indicated
Code:
'''''' normal module code
Option Explicit
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
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
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, _
lParam As Any) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" ( _
ByVal hHook As Long) As Long
'Private Declare Function PostMessage Lib "user32.dll" _
' Alias "PostMessageA" ( _
' ByVal hwnd As Long, _
' ByVal wMsg As Long, _
' ByVal wParam As Long, _
' ByVal lParam 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
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 Const WM_KEYDOWN As Long = &H100
'Private Const WM_KEYUP As Long = &H101
'Private Const VK_UP As Long = &H26
'Private Const VK_DOWN As Long = &H28
'Private Const WM_LBUTTONDOWN As Long = &H201
Private mLngMouseHook As Long
Private mListBoxHwnd As Long
Private mbHook As Boolean
Private mCtl As MSForms.Control
Dim n As Long
Sub HookListBoxScroll(frm As Object, ctl As MSForms.Control)
Dim lngAppInst As Long
Dim hwndUnderCursor As Long
Dim tPT As POINTAPI
GetCursorPos tPT
hwndUnderCursor = WindowFromPoint(tPT.X, tPT.Y)
If Not frm.ActiveControl Is ctl Then
ctl.SetFocus
End If
If mListBoxHwnd <> hwndUnderCursor Then
UnhookListBoxScroll
Set mCtl = ctl
mListBoxHwnd = hwndUnderCursor
lngAppInst = GetWindowLong(mListBoxHwnd, GWL_HINSTANCE)
' PostMessage mListBoxHwnd, WM_LBUTTONDOWN, 0&, 0&
If Not mbHook Then
mLngMouseHook = SetWindowsHookEx( _
WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0)
mbHook = mLngMouseHook <> 0
End If
End If
End Sub
Sub UnhookListBoxScroll()
If mbHook Then
Set mCtl = Nothing
UnhookWindowsHookEx mLngMouseHook
mLngMouseHook = 0
mListBoxHwnd = 0
mbHook = False
End If
End Sub
Private Function MouseProc( _
ByVal nCode As Long, ByVal wParam As Long, _
ByRef lParam As MOUSEHOOKSTRUCT) As Long
Dim idx As Long
On Error GoTo errH
If (nCode = HC_ACTION) Then
If WindowFromPoint(lParam.pt.X, lParam.pt.Y) = mListBoxHwnd Then
If wParam = WM_MOUSEWHEEL Then
MouseProc = True
' If lParam.hwnd > 0 Then
' PostMessage mListBoxHwnd, WM_KEYDOWN, VK_UP, 0
' Else
' PostMessage mListBoxHwnd, WM_KEYDOWN, VK_DOWN, 0
' End If
' PostMessage mListBoxHwnd, WM_KEYUP, VK_UP, 0
If lParam.hwnd > 0 Then idx = -1 Else idx = 1
idx = idx + mCtl.ListIndex
If idx >= 0 Then mCtl.ListIndex = idx
Exit Function
End If
Else
UnhookListBoxScroll
End If
End If
MouseProc = CallNextHookEx( _
mLngMouseHook, nCode, wParam, ByVal lParam)
Exit Function
errH:
UnhookListBoxScroll
End Function
'''''''' end normal module code
'http://social.Msdn.microsoft.com/Forums/en-US/isvvba/thread/7d584120-a929-4e7c-9ec2-9998ac639bea#7738fb96-12be-4e3c-af5c-abaae64a5e94
'
'19-Jul-2012
''''' Userform code
Private Sub comboBox1_MouseMove( _
ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
HookListBoxScroll Me, Me.ComboBox1
End Sub
Private Sub ListBox1_MouseMove( _
ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
HookListBoxScroll Me, Me.ListBox1
End Sub
Private Sub ListBox2_MouseMove( _
ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
HookListBoxScroll Me, Me.ListBox2
End Sub
Private Sub UserForm_Initialize()
Dim i As Long
Dim s As String
s = "this is line "
For i = 1 To 50
Me.ComboBox1.AddItem s & i
Me.ListBox1.AddItem s & i
Me.ListBox2.AddItem s & i
Next
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
UnhookListBoxScroll
End Sub
''''''' end Userform codePeter Thornton
Last edited by a moderator:
