ตารางกริด (MS Flex Grid) ธรรมดา ที่ไม่ธรรมดา ... ตอนใช้ Wheel Mouse ใน MS FlexGrid ได้

Option Explicit

' =========================================
' นำไปใช้งานในแต่ละฟอร์ม
' =========================================
Public Sub MouseWheel( _
    ByVal MouseKeys As Long, _
    ByVal Rotation As Long, _
    ByVal AxisX As Long, _
    ByVal AxisY As Long _
    )

' ตำแหน่งที่ต้องเลื่อนใหม่
Dim NewAxis As Long
' หาค่าจำนวนแถวทั้งหมดที่แสดงผลใน MS FlexGrid
Dim RowALL As Single

On Error Resume Next

    With fgData
        ' หาค่าของการเลื่อน Wheel Mouse
        ' ด้วยค่าความสูงของ MS FlexGrid หารด้วยความสูงของแต่ละแถว (ตั้งไว้ที่ 330 Twips)
        ' จะได้ค่าตามจำนวนแถวทั้งหมดของ MS FlexGrid (รวม Header)
        RowALL = Int(.Height \ .RowHeight(0)) - 1 ' ลดลงไป 1 เพราะมันมี Column header

        If .Rows < RowALL Then Exit Sub
        
        ' หากค่า Rotation เป็นบวก หมายความว่าเลื่อน Scroll Mouse ขึ้นด้านบน
        ' ลดค่า NewAxis ลง
        If Rotation > 0 Then
            NewAxis = .TopRow - RowALL
            If NewAxis < 1 Then NewAxis = 1
            
        ' เลื่อน Scroll Mouse ลงด้านล่าง ให้เพิ่มค่า NewAxis ขึ้นอีก
        Else
            NewAxis = .TopRow + RowALL
            If NewAxis > .Rows - 1 Then NewAxis = .Rows - 1
        End If
        
        .TopRow = NewAxis
    
    End With

End Sub

Private Sub Form_Activate()
    ' =============================================================
    ' นำไปใช้งานในแต่ละฟอร์ม
    ' เรียกใช้งาน WheelHook เมื่อ Form เริ่มทำงาน (หากกรณีที่เป็นฟอร์มลูกของ MDI Form)
    Call WheelHook(Me)
    ' =============================================================
End Sub

Private Sub Form_Load()
    
    Me.Move (Screen.Width - Width) \ 2, (Screen.Height - Height) \ 2
    Call SetupGrid              ' ตั้งค่าคุณสมบัติให้กับ MS FlexGrid แบบ Run - Time
    Call DisplayfgData      ' นำข้อมูลเข้าไปยัง MS FlexGrid
    
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    ' =========================================
    ' นำไปใช้งานในแต่ละฟอร์ม ... ยกเลิกการจับจองพื้นที่หน่วยความจำ
    ' =========================================
    Call WheelUnHook
End Sub

' ======================================================
' การตั้งค่าคุณสมบัติของ MS FlexGrid ในลักษณะของ Run Time
' ======================================================
Sub SetupGrid()
    With fgData
        .Cols = 3
        .Rows = 500
        .ColWidth(0) = 0
        .ColWidth(1) = 1800
        .ColWidth(2) = 3600
        .TextMatrix(0, 0) = "PK"
        .TextMatrix(0, 1) = "รหัสสินค้า"
        .TextMatrix(0, 2) = "ราคาสินค้า"
    End With
    
    ' ส่วนของการแสดงผลให้กับ MS FlexGrid
    With fgData
        .RowHeightMin = 330
        .SelectionMode = flexSelectionByRow
        .AllowUserResizing = flexResizeNone
        .FixedAlignment(2) = flexAlignRightCenter
        .ColAlignment(2) = flexAlignRightCenter
        .FocusRect = flexFocusHeavy
    End With
    
    ' ส่วนของการสร้างสีสันสวยงามให้กับ MS FlexGrid
    With fgData
        .BackColorFixed = RGB(133, 175, 255)
        .ForeColorFixed = vbBlack
        .BackColorBkg = RGB(245, 245, 245)
        .BackColorSel = RGB(121, 255, 53)
        .ForeColorSel = vbBlack
        .BackColor = RGB(255, 255, 204)
        .ForeColor = vbBlack
        .GridColor = vbBlack
    End With
End Sub

' ======================================================
' การนำข้อมูลเข้า MS FlexGrid
' ======================================================
Sub DisplayfgData()
Dim sRow As Integer
    Randomize
    ' ตัวอย่างข้อมูล 499 รายการ
    For sRow = 1 To 499
        fgData.TextMatrix(sRow, 0) = sRow
        fgData.TextMatrix(sRow, 1) = Chr$(Int(Rnd() * 26) + 65) & Int(100 * Rnd)
        fgData.TextMatrix(sRow, 2) = Format(Int(10000 * Rnd), "0.00#,##")
    Next
    SendKeys "{UP}"
End Sub

Option Explicit

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 Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    pDst As Any, _
    pSrc As Any, _
    ByVal ByteLen 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     ' 522 ในฐาน 10

Dim LocalHwnd As Long
Dim LocalPrevWndProc As Long
Dim GetForm As Form

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
    Dim Rotation As Long
    Dim AxisX As Long
    Dim AxisY As Long
    
    ' เกิดการหมุนลูกกลิ้ง (Wheel) ของเมาส์
    If Lmsg = WM_MOUSEWHEEL Then
        MouseKeys = Wparam And 65535
        Rotation = Wparam / 65536
        AxisX = Lparam And 65535
        AxisY = Lparam / 65536
        GetForm.MouseWheel MouseKeys, Rotation, AxisX, AxisY
    End If
    
    ' ค่าพารามิเตอร์ต่างๆ ต้องเปิดจาก MSDN ดูเอาเองล่ะครับ ...
    ' หรือ อ่านข้อมูลเพิ่มเติมได้จากบทความเรื่องการแสดง Icon ใน System Tray
    WindowProc = CallWindowProc(LocalPrevWndProc, Lwnd, Lmsg, Wparam, Lparam)
    

End Function

Public Sub WheelHook(frm As Form)

    On Error Resume Next

    Set GetForm = frm
    LocalHwnd = frm.hWnd
    LocalPrevWndProc = SetWindowLong(LocalHwnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub

Public Sub WheelUnHook()
Dim blnFlag As Long

On Error Resume Next
    blnFlag = SetWindowLong(LocalHwnd, GWL_WNDPROC, LocalPrevWndProc)
    Set GetForm = Nothing
End Sub