Option Explicit
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 FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Const GWL_WNDPROC = -4
Private Const WM_MouseWheel = &H20A
Private hWnd_UserForm As Long
Private lngWndProc As Long
'this traps the mousewheel scroll message as it's sent to your form by Wiindows,
'then it calls the procedure in the form's code module in order to scroll the list
Private Function WindowProc(ByVal lWnd As Long, ByVal lMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim MouseKeys As Long
Dim Rotation As Long
If lMsg = WM_MouseWheel Then
MouseKeys = wParam And 65535
Rotation = wParam / 65536
'you will have to replace "UserForm1" in the following line, with the name of your form ;-)
UserForm1.ComboBox1_MouseWheel Rotation
End If
WindowProc = CallWindowProc(lngWndProc, lWnd, lMsg, wParam, lParam)
End Function
Public Sub WheelHook(ClientForm As UserForm)
hWnd_UserForm = FindWindow("ThunderDFrame", ClientForm.Caption)
lngWndProc = SetWindowLong(hWnd_UserForm, GWL_WNDPROC, AddressOf WindowProc)
End Sub
Public Sub WheelUnHook()
Dim lRet As Long
lRet = SetWindowLong(hWnd_UserForm, GWL_WNDPROC, lngWndProc)
End Sub
'***************************************************
'Created by member Timbo @ xtremevbtalk.com
'Adapted from the ListBox solution by Mathieu Plante
'***************************************************
'#############################################################
'don't forget to substitute "ComboBox1" with your control name
'#############################################################
Option Explicit
'flag to determine if the control is currently hooked
Private blnHooked As Boolean
Private Sub ComboBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'create the hook when the mouse is over the control
ComboBox1_Hook
End Sub
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'destroy the hook when the mouse is not over the control
ComboBox1_UnHook
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
'ensure the hook is destroyed before the form closes
ComboBox1_UnHook
End Sub
Private Sub UserForm_Deactivate()
'destroy the hook if another window takes the focus
ComboBox1_UnHook
End Sub
Private Sub ComboBox1_Hook()
'only hook the control if it is not already hooked
If Not blnHooked Then
WheelHook Me
blnHooked = True
End If
End Sub
Private Sub ComboBox1_UnHook()
'only destroy hook the control if it is already hooked
If blnHooked Then
WheelUnHook
blnHooked = False
End If
End Sub
'custom method to execute the mousewheel scroll action
Public Sub ComboBox1_MouseWheel(ByVal Rotation As Long)
Dim lngNewIndex As Long
Static intCounter As Integer
'a little retarding routine to make the mousewheel less sensitive!
intCounter = intCounter + 1
If Not intCounter = 3 Then Exit Sub
intCounter = 0
With Me.ComboBox1
If Rotation < 0 Then
lngNewIndex = .ListIndex + 1
If .ListCount > lngNewIndex Then .ListIndex = lngNewIndex
Else
If Not .ListIndex <= -1 Then .ListIndex = .ListIndex - 1
End If
End With
End Sub
Private Sub ComboBox1_Hook() 'only hook the control if it is not already hooked
If Not blnHooked Then
WheelHook Me
blnHooked = True
End If
End Sub
Private Sub ComboBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) 'create the hook when the mouse is over the control
ComboBox1_Hook
End Sub