Option Explicit

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 Type POINTAPI
    x As Long
    y As Long
End Type

Private Const WM_CLOSE = &H10
Private Const GWL_WNDPROC = - 4 

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, "prevptr") =  0  Then
        p = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf FrmProc)
        SetProp hwnd, "prevptr", p
    End If
    For Each Grid In Form.Controls
        If TypeOf Grid Is DataGrid Then
            p = SetWindowLong(Grid.hwnd, GWL_WNDPROC, AddressOf WindowProc)
            SetProp Grid.hwnd, "prevptr", p
            SetProp Grid.hwnd, "gridptr", ObjPtr(Grid)
        End If
    Next
End Sub

Private Function WindowProc(ByVal hw As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim lpPrevWndProc As Long
Dim GridPtr As Long
Dim hwnd As Long
Dim pa As POINTAPI
Dim oList As Object
    lpPrevWndProc = GetProp(hw, "prevptr")
    If lpPrevWndProc =  0  Then Exit Function
    Select Case uMsg
        Case  522 
            GetCursorPos pa
            hwnd = WindowFromPoint(pa.x, pa.y)
            GridPtr = GetProp(hwnd, "gridptr")
            If GridPtr <>  0  Then
                Set oList = ObjFromPtr(GridPtr)
                If Abs(wParam) =  7864320  Then
                    oList.Scroll  0 , -(wParam / Abs(wParam))
                Else
                    oList.Scroll  0 , -(wParam / Abs(wParam)) *  10 
                End If
            End If
        Case WM_CLOSE
            RemoveProp hw, "prevptr"
            RemoveProp hw, "gridptr"
            SetWindowLong hw, GWL_WNDPROC, lpPrevWndProc
        Case Else
            WindowProc = CallWindowProc(lpPrevWndProc, hw, uMsg, wParam, lParam)
    End Select
End Function

Private Function FrmProc(ByVal hw As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim lpPrevWndProc As Long
Dim hwnd As Long
Dim pa As POINTAPI
    lpPrevWndProc = GetProp(hw, "prevptr")
    Select Case uMsg
        Case  522 
            GetCursorPos pa
            hwnd = WindowFromPoint(pa.x, pa.y)
            If GetProp(hwnd, "prevptr") <>  0  Then SendMessage hwnd, uMsg, wParam, lParam
        Case WM_CLOSE
            RemoveProp hw, "prevptr"
            SetWindowLong hw, GWL_WNDPROC, lpPrevWndProc
        Case Else
            FrmProc = CallWindowProc(lpPrevWndProc, 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