source - http://www.vbforums.com/showthread.php?388222-VB6-MouseWheel-with-Any-Control-(originally-just-MSFlexGrid-Scrolling)
JavaScript:
//test.frm
Private Sub Form_Load()
Dim N As Integer
Dim I As Integer
' Dummy values
With MSFlexGrid1
.Rows = 100
.Cols = 5
For N = .FixedRows To .Rows - 1
.TextMatrix(N, 0) = "Row " & N
Next N
End With
With MSFlexGrid2
.Rows = 100
.Cols = 5
For N = .FixedRows To .Rows - 1
.TextMatrix(N, 0) = "Row " & N
Next N
End With
For N = 0 To 20
Combo1.AddItem "Test " & N
List1.AddItem "Test " & N
Next N
' Hook Form
Call WheelHook(Me.hWnd)
' Hook Controls to be ignored
Call WheelHook(Combo1.hWnd)
Call WheelHook(List1.hWnd)
Call WheelHook(Text1.hWnd)
Form2.Show
End Sub
Private Sub Form_Unload(Cancel As Integer)
Call WheelUnHook(Me.hWnd)
Call WheelUnHook(Combo1.hWnd)
Call WheelUnHook(Text1.hWnd)
Unload Form2
End Sub
' Here you can add scrolling support to controls that don't normally respond.
' This Sub could always be moved to a module to make scrollwheel behaviour
' generic across forms.
' ===========================================================================
Public Sub MouseWheel(ByVal MouseKeys As Long, ByVal Rotation As Long, ByVal Xpos As Long, ByVal Ypos As Long)
Dim ctl As Control
Dim bHandled As Boolean
Dim bOver As Boolean
For Each ctl In Controls
' Is the mouse over the control
On Error Resume Next
bOver = (ctl.Visible And IsOver(ctl.hWnd, Xpos, Ypos))
On Error GoTo 0
If bOver Then
' If so, respond accordingly
bHandled = True
Select Case True
Case TypeOf ctl Is MSFlexGrid
FlexGridScroll ctl, MouseKeys, Rotation, Xpos, Ypos
Case TypeOf ctl Is PictureBox
PictureBoxZoom ctl, MouseKeys, Rotation, Xpos, Ypos
Case TypeOf ctl Is ListBox, TypeOf ctl Is TextBox, TypeOf ctl Is ComboBox
' These controls already handle the mousewheel themselves, so allow them to:
If ctl.Enabled Then ctl.SetFocus
Case Else
bHandled = False
End Select
If bHandled Then Exit Sub
End If
bOver = False
Next ctl
' Scroll was not handled by any controls, so treat as a general message send to the form
Me.Caption = "Form Scroll " & IIf(Rotation < 0, "Down", "Up")
End Sub
JavaScript:
//module1.bas
' Store WndProcs
Private Declare Function GetProp Lib "user32.dll" Alias "GetPropA" ( _
ByVal hWnd As Long, _
ByVal lpString As String) As Long
Private Declare Function SetProp Lib "user32.dll" Alias "SetPropA" ( _
ByVal hWnd As Long, _
ByVal lpString As String, _
ByVal hData As Long) As Long
Private Declare Function RemoveProp Lib "user32.dll" Alias "RemovePropA" ( _
ByVal hWnd As Long, _
ByVal lpString As String) As Long
' Hooking
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 SendMessage Lib "user32.dll" Alias "SendMessageA" ( _
ByVal hWnd As Long, _
ByVal Msg As Long, _
wParam As Any, _
lParam As Any) As Long
' Position Checking
Private Declare Function GetWindowRect Lib "user32" ( _
ByVal hWnd As Long, _
lpRect As RECT) As Long
Private Declare Function GetParent Lib "user32" ( _
ByVal hWnd As Long) As Long
Private Const GWL_WNDPROC = -4
Private Const WM_MOUSEWHEEL = &H20A
Private Const CB_GETDROPPEDSTATE = &H157
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
' Check Messages
' ================================================
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
Dim Xpos As Long
Dim Ypos As Long
Dim fFrm As Form
Select Case Lmsg
Case WM_MOUSEWHEEL
MouseKeys = wParam And 65535
Rotation = wParam / 65536
Xpos = lParam And 65535
Ypos = lParam / 65536
Set fFrm = GetForm(Lwnd)
If fFrm Is Nothing Then
' it's not a form
If Not IsOver(Lwnd, Xpos, Ypos) And IsOver(GetParent(Lwnd), Xpos, Ypos) Then
' it's not over the control and is over the form,
' so fire mousewheel on form (if it's not a dropped down combo)
If SendMessage(Lwnd, CB_GETDROPPEDSTATE, 0&, 0&) <> 1 Then
GetForm(GetParent(Lwnd)).MouseWheel MouseKeys, Rotation, Xpos, Ypos
Exit Function ' Discard scroll message to control
End If
End If
Else
' it's a form so fire mousewheel
If IsOver(fFrm.hWnd, Xpos, Ypos) Then fFrm.MouseWheel MouseKeys, Rotation, Xpos, Ypos
End If
End Select
WindowProc = CallWindowProc(GetProp(Lwnd, "PrevWndProc"), Lwnd, Lmsg, wParam, lParam)
End Function
' Hook / UnHook
' ================================================
Public Sub WheelHook(ByVal hWnd As Long)
On Error Resume Next
SetProp hWnd, "PrevWndProc", SetWindowLong(hWnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub
Public Sub WheelUnHook(ByVal hWnd As Long)
On Error Resume Next
SetWindowLong hWnd, GWL_WNDPROC, GetProp(hWnd, "PrevWndProc")
RemoveProp hWnd, "PrevWndProc"
End Sub
' Window Checks
' ================================================
Public Function IsOver(ByVal hWnd As Long, ByVal lX As Long, ByVal lY As Long) As Boolean
Dim rectCtl As RECT
GetWindowRect hWnd, rectCtl
With rectCtl
IsOver = (lX >= .Left And lX <= .Right And lY >= .Top And lY <= .Bottom)
End With
End Function
Private Function GetForm(ByVal hWnd As Long) As Form
For Each GetForm In Forms
If GetForm.hWnd = hWnd Then Exit Function
Next GetForm
Set GetForm = Nothing
End Function
' Control Specific Behaviour
' ================================================
Public Sub FlexGridScroll(ByRef FG As MSFlexGrid, ByVal MouseKeys As Long, ByVal Rotation As Long, ByVal Xpos As Long, ByVal Ypos As Long)
Dim NewValue As Long
Dim Lstep As Single
On Error Resume Next
With FG
Lstep = .Height / .RowHeight(0)
Lstep = Int(Lstep)
If .Rows < Lstep Then Exit Sub
Do While Not (.RowIsVisible(.TopRow + Lstep))
Lstep = Lstep - 1
Loop
If Rotation > 0 Then
NewValue = .TopRow - Lstep
If NewValue < 1 Then
NewValue = 1
End If
Else
NewValue = .TopRow + Lstep
If NewValue > .Rows - 1 Then
NewValue = .Rows - 1
End If
End If
.TopRow = NewValue
End With
End Sub
Public Sub PictureBoxZoom(ByRef picBox As PictureBox, ByVal MouseKeys As Long, ByVal Rotation As Long, ByVal Xpos As Long, ByVal Ypos As Long)
picBox.Cls
picBox.Print "MouseWheel " & IIf(Rotation < 0, "Down", "Up")
End Sub