Option Explicit

Private Declare Function SystemParametersInfo Lib "user32.dll" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "user32" 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 SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Private Const WM_MOUSEWHEEL As Long = &H20A
Private Const WM_CLOSE As Long = &H10
Private Const GWL_WNDPROC As Long = - 4 
Private Const WHEEL_DELTA As Long =  120 
Private Const SPI_GETWHEELSCROLLLINES As Long =  104 

Private Const PROP_PREVPROC = "prevptr"
Private Const PROP_GRIDPTR = "gridptr"
Private Const PROP_DELTA = "delta"

Private Type POINTAPI
    X As Long
    Y As Long
End Type

Public Sub AddScroll2Grids(Form As Form)
Dim Grid As Object
Dim p As Long
Dim hwnd As Long
    If Form.MDIChild Then
        hwnd = GetParent(Form.hwnd)
        hwnd = GetParent(hwnd)
    Else
        hwnd = Form.hwnd
    End If
    If GetProp(hwnd, PROP_PREVPROC) =  0  Then
        p = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf FrmProc)
        SetProp hwnd, PROP_PREVPROC, p
    End If
    For Each Grid In Form.Controls
        Select Case TypeName(Grid): Case "DataGrid", "DBGrid", "MSFlexGrid", "MSHFlexGrid"
            p = SetWindowLong(Grid.hwnd, GWL_WNDPROC, AddressOf GridProc)
            SetProp Grid.hwnd, PROP_PREVPROC, p
            SetProp Grid.hwnd, PROP_GRIDPTR, ObjPtr(Grid)
        End Select
    Next
End Sub

Private Function GridProc(ByVal hw As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
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
            End If
        Case WM_CLOSE
            RemoveProp hw, PROP_PREVPROC
            RemoveProp hw, PROP_GRIDPTR
            RemoveProp hw, PROP_DELTA
            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

Private Function FrmProc(ByVal hw As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim lPrevWndProc As Long
Dim hwnd As Long
Dim pa As POINTAPI
    lPrevWndProc = GetProp(hw, PROP_PREVPROC)
    Select Case uMsg
        Case WM_MOUSEWHEEL
            GetCursorPos pa
            hwnd = WindowFromPoint(pa.X, pa.Y)
            If GetProp(hwnd, PROP_PREVPROC) <>  0  Then SendMessage hwnd, uMsg, wParam, lParam
        Case WM_CLOSE
            RemoveProp hw, PROP_PREVPROC
            SetWindowLong hw, GWL_WNDPROC, lPrevWndProc
        Case Else
            FrmProc = CallWindowProc(lPrevWndProc, hw, uMsg, wParam, lParam)
    End Select
End Function

Private Function ObjFromPtr(lObjPtr As Long) As Object
Dim LoTmp As Object
    If lObjPtr <>  0  Then
        CopyMemory LoTmp, lObjPtr,  4 
        Set ObjFromPtr = LoTmp
        CopyMemory LoTmp,  0 &,  4 
    End If
End Function