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
Public Sub WheelUnHook()
Dim WorkFlag As Long
On Error Resume Next
WorkFlag = SetWindowLong(LocalHwnd, GWL_WNDPROC, LocalPrevWndProc)
Set MyForm = Nothing
End Sub
Public Sub MouseWheel(ByVal MouseKeys As Long, ByVal Rotation As Long, ByVal Xpos As Long, ByVal Ypos As Long)
Dim NewValue As Long
Dim ipToAdd As Integer
On Error Resume Next
If Rotation > 0 Then
ipToAdd = -3
Else
ipToAdd = 3
End If
If DATAGRID_Customers(0).Visible Then
ADODC_CustbyName.RecordSet.Bookmark = adoCustbyName.RecordSet.Bookmark + ipToAdd
ElseIf lstCustomers(1).Visible Then
ADODC_CustbyCode.RecordSet.Bookmark = adoCustbyCode.RecordSet.Bookmark + ipToAdd
End If
End Sub
I know, i'm guilty of using my blog as a code repository so I don't forget stuff, more modern and interesting stuff will follow!