Geeks With Blogs

News


Neil Smith [blog]code til ur fingers bleed

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!

Posted on Wednesday, July 18, 2007 6:56 AM | Back to top


Comments on this post: Been a while :-)

No comments posted yet.
Your comment:
 (will show your gravatar)


Copyright © Neil Smith | Powered by: GeeksWithBlogs.net