Public Function GridProc(ByVal hw As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'http://www.sql.ru/forum/actualthread.aspx?tid=703320

Dim lPrevWndProc As Long
Dim lLines2Scroll As Long
Dim GridPtr As Long
Dim Delta As Long
Dim hwnd As Long
Dim oList As Object
Dim pa As POINTAPI
Dim dScroll As Integer
    lPrevWndProc = GetProp(hw, PROP_PREVPROC)
    If lPrevWndProc =  0  Then Exit Function
    Select Case uMsg
        Case WM_MOUSEWHEEL
            GetCursorPos pa
            hwnd = WindowFromPoint(pa.X, pa.Y)
            GridPtr = GetProp(hwnd, PROP_GRIDPTR)
            If GridPtr <>  0  Then
                SystemParametersInfo SPI_GETWHEELSCROLLLINES,  0 , lLines2Scroll,  0 
                Delta = GetProp(hw, PROP_DELTA) + wParam / &H10000
                dScroll = -lLines2Scroll * (Delta \ WHEEL_DELTA) * ( 10  +  9  * (Not (wParam = - 7864316  Or wParam =  7864324 )))
                Set oList = ObjFromPtr(GridPtr)
                Select Case TypeName(oList)
                    Case "DataGrid", "DBGrid"
                        oList.Scroll  0 , dScroll
                    Case "MSFlexGrid", "MSHFlexGrid"
                        On Error GoTo errh
                        If oList.TopRow + dScroll <= oList.FixedRows -  1  Then
                            oList.TopRow = oList.FixedRows
                        ElseIf oList.TopRow + dScroll >= oList.Rows Then
                            oList.TopRow = oList.Rows -  1 
                        Else
                            oList.TopRow = oList.TopRow + dScroll
                        End If
                End Select
                SetProp hw, PROP_DELTA, Delta Mod WHEEL_DELTA
            ElseIf hwnd <> hw Then
                If GetProp(hwnd, PROP_MSGSENT) =  0  Then
                    SetProp hwnd, PROP_MSGSENT,  1 
                    SendMessage hwnd, uMsg, wParam, lParam
                Else
                    RemoveProp hwnd, PROP_MSGSENT
                End If
            Else
                GridProc = CallWindowProc(lPrevWndProc, hw, uMsg, wParam, lParam)
            End If
        Case WM_CLOSE
            RemoveProp hw, PROP_PREVPROC
            RemoveProp hw, PROP_GRIDPTR
            RemoveProp hw, PROP_DELTA
            RemoveProp hw, PROP_MSGSENT
            SetWindowLong hw, GWL_WNDPROC, lPrevWndProc
        Case Else
            GridProc = CallWindowProc(lPrevWndProc, hw, uMsg, wParam, lParam)
    End Select
    Exit Function
errh:
    Debug.Print Err.Description, oList.Row + dScroll
End Function

Public Sub InitWndProc(Obj As Object)
'http://www.sql.ru/forum/actualthread.aspx?tid=703320

Dim hwnd As Long
If App.LogMode <>  0  Then
  hwnd =  0 
  On Error Resume Next
  hwnd = Obj.hwnd
  On Error GoTo  0 
  
  If hwnd <>  0  Then
    If GetProp(hwnd, PROP_PREVPROC) =  0  Then
      SetProp hwnd, PROP_PREVPROC, SetWindowLong(hwnd, GWL_WNDPROC, AddressOf GridProc)
      If ValIN(TypeName(Obj), "DataGrid", "DBGrid", "MSFlexGrid", "MSHFlexGrid") Then
        SetProp hwnd, PROP_GRIDPTR, ObjPtr(Obj)
      End If
    End If
  End If
End If

End Sub

Public Function ValIN(Value As Variant, Arg1 As Variant, Optional Arg2 As Variant, Optional Arg3 As Variant, Optional Arg4 As Variant, Optional Arg5 As Variant, Optional Arg6 As Variant, Optional Arg7 As Variant, Optional Arg8 As Variant, Optional Arg9 As Variant, Optional Arg10 As Variant) As Boolean

ValIN = True
If Value = Arg1 Then Exit Function
If Not IsMissing(Arg2) Then If Value = Arg2 Then Exit Function
If Not IsMissing(Arg3) Then If Value = Arg3 Then Exit Function
If Not IsMissing(Arg4) Then If Value = Arg4 Then Exit Function
If Not IsMissing(Arg5) Then If Value = Arg5 Then Exit Function
If Not IsMissing(Arg6) Then If Value = Arg6 Then Exit Function
If Not IsMissing(Arg7) Then If Value = Arg7 Then Exit Function
If Not IsMissing(Arg8) Then If Value = Arg8 Then Exit Function
If Not IsMissing(Arg9) Then If Value = Arg9 Then Exit Function
If Not IsMissing(Arg10) Then If Value = Arg10 Then Exit Function
ValIN = False

End Function