Been a while :-)

Comments | Share

Hi there, been a while since posting though I do read GWB most days.  Involved in a number of new projects and looking to get back into my blogging.  Got an ancient vb6 app with lots of datagrids bound to adodc controls and need to add mousewheel support, customers are moaning that it doesn't support mouse wheels, the fact that vb6 pre dates mouse wheels doesn't wash.. anyway, someone might find it useful so here it is :-

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

Public Const MK_CONTROL = &H8
Public Const MK_LBUTTON = &H1
Public Const MK_RBUTTON = &H2
Public Const MK_MBUTTON = &H10
Public Const MK_SHIFT = &H4
Private Const GWL_WNDPROC = -4
Private Const WM_MOUSEWHEEL = &H20A

Dim LocalHwnd As Long
Dim LocalPrevWndProc As Long
Dim MyForm As Form

Private Sub Form_Activate()
WheelHook Me
End Sub

Private Sub Form_Deactivate()
WheelUnHook
End Sub

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, Rotation As Long, Xpos As Long, Ypos As Long
   
   If Lmsg = WM_MOUSEWHEEL Then
       MouseKeys = wParam And 65535
       Rotation = wParam / 65536
       Xpos = lParam And 65535
       Ypos = lParam / 65536
       MyForm.MouseWheel MouseKeys, Rotation, Xpos, Ypos
   End If
   WindowProc = CallWindowProc(LocalPrevWndProc, Lwnd, Lmsg, wParam, lParam)
End Function

Public Sub WheelHook(PassedForm As Form)

    On Error Resume Next
        Set MyForm = PassedForm
        LocalHwnd = PassedForm.hWnd
        LocalPrevWndProc = SetWindowLong(LocalHwnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub