如何让MsHFlexGrid控件支持滚轮鼠标

Question

见标题

Answer 1

我看了其它的贴字，datagrid控件是可以的，但是mshflexgrid控件是不行的，不知道有没有好的解决方法。

Answer 2

setwindowlong 改写mshflexgrid的窗口过程
捕获WM_MOUSEWHEEL

Answer 3

将如下内容稍微改写一下就行：截获鼠标滑轮滚动事件
Option Explicit
Const SM_MOUSEWHEELPRESENT As Long = 75 
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Const WM_MOUSEWHEEL As Integer = &H20A
Const WM_MOUSEHOVER As Integer = &H2A1
Const WM_MOUSELEAVE As Integer = &H2A3
Const WM_KEYDOWN As Integer = &H100
Const WM_KEYUP As Integer = &H101
Const WM_CHAR As Integer = &H102
Const MK_LBUTTON As Integer = &H1
Const MK_RBUTTON As Integer = &H2
Const MK_MBUTTON As Integer = &H10
Const MK_SHIFT As Integer = &H4
Const MK_CONTROL As Integer = &H8Private Type POINTAPI
        X As Long
        Y As Long
End Type
Private Type MSG
    hwnd As Long
    message As Long
    wParam As Long
    lParam As Long
    time As Long
    pt As POINTAPI
End Type
Private Declare Function GetMessage Lib "user32" Alias "GetMessageA" ( _
    lpMsg As MSG, _
    ByVal hwnd As Long, _
    ByVal wMsgFilterMin As Long, _
    ByVal wMsgFilterMax As Long _
) As Long
Private Declare Function DispatchMessage Lib "user32" Alias "DispatchMessageA" ( _
    lpMsg As MSG _
) As Long
Private Declare Function TranslateMessage Lib "user32" ( _
    lpMsg As MSG _
) As LongPrivate Declare Function TRACKMOUSEEVENT Lib "user32" Alias "TrackMouseEvent" ( _
    lpEventTrack As TRACKMOUSEEVENT _
) As Boolean
Private Type TRACKMOUSEEVENT
    cbSize As Long
    dwFlags As Long
    hwndTrack As Long
    dwHoverTime As Long
End Type
    Const TME_HOVER As Long = &H1
    Const TME_LEAVE As Long = &H2
    Const TME_QUERY As Long = &H40000000
    Const TME_CANCEL As Long = &H80000000
    
    Const HOVER_DEFAULT As Long = &HFFFFFFFFPrivate Declare Function GetCursorPos Lib "user32" ( _
    lpPoint As POINTAPI _
) As Long
    
Private Declare Function WindowFromPoint Lib "user32" ( _
    ByVal X As Long, _
    ByVal Y As Long _
) As Long
     
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" ( _
    ByVal hwnd As Long, _
    ByVal lpClassName As String, _
    ByVal nMaxCount As Long _
) As LongDim m_blnWheelPresent As Boolean
Dim m_blnWheelTracking As Boolean
Dim m_blnKeepSpinnig As Boolean
Dim m_tMSG As MSGConst m_sCurOffset As Single = 112
Const m_WheelForward As Long = -1
Const m_WheelBackward As Long = 1    Dim m_sScaleMultiplier_H As Single
    Dim m_sScaleMax_H As Single
    Dim m_sScaleMin_H As Single
    Dim m_sScalevalue_H As Single
    
    Dim m_sScaleMultiplier_V As Single
    Dim m_sScaleMax_V As Single
    Dim m_sScaleMin_V As Single
    Dim m_sScalevalue_V As Single
    
    Dim m_lWalkWay As Long
    Dim m_lMutiplier_Small As Long
    Dim m_lMutiplier_Large As Long
    Dim m_lSamplevalue As Long
Sub WatchForWheel(hClient As Long, Optional blnWheelAround As Boolean)
Dim i As Integer
Dim lResult As Long
Dim bResult As Boolean
Dim tTrackMouse As TRACKMOUSEEVENT
Dim tMouseCords As POINTAPI
Dim lX As Long, lY As Long
Dim lCurrentHwnd As Long
Dim iDirection As Integer
Dim iKeys As Integer
If IsMissing(blnWheelAround) Then
    m_blnKeepSpinnig = False
Else
    m_blnKeepSpinnig = blnWheelAround
End Ifm_blnWheelTracking = True
    Do While m_blnWheelTracking
    
        lResult = GetCursorPos(tMouseCords)
            lX = tMouseCords.X
            lY = tMouseCords.Y
        
        lCurrentHwnd = WindowFromPoint(lX, lY)
        
        If lCurrentHwnd <> hClient Then
            If m_blnKeepSpinnig = False Then
                m_blnWheelTracking = False
                Exit Do
            End If
        End If
        
        lResult = GetMessage(m_tMSG, Me.hwnd, 0, 0)
        
        lResult = TranslateMessage(m_tMSG)
        lResult = DispatchMessage(m_tMSG)
        DoEvents
           
        Select Case m_tMSG.message
            Case WM_MOUSEWHEEL
                
                Call WheelAction(hClient, m_tMSG.wParam)
                
            
            Case WM_MOUSELEAVE
                m_blnWheelTracking = False
                
        End Select
        
        DoEvents
    LoopEnd Sub

Answer 4

Sub WheelAction(hClient As Long, wParam)
Dim iKey As Integer
Dim iDir As Integer
iKey = CInt("&H" & (Right(Hex(wParam), 4)))
iDir = Sgn(wParam \ 32767)
                
Select Case hClient
    Case Picture1.hwnd
        
        If iKey And MK_CONTROL Then
            If iKey And MK_SHIFT Then
                m_sScalevalue_H = m_sScalevalue_H + iDir * m_sScaleMultiplier_H
            Else
                 m_sScalevalue_H = m_sScalevalue_H + iDir
            End If
            
            If m_sScalevalue_H <= m_sScaleMin_H Then m_sScalevalue_H = m_sScaleMin_H
            If m_sScalevalue_H >= m_sScaleMax_H Then m_sScalevalue_H = m_sScaleMax_H
        
            Picture3.Left = Picture1.Left + Picture1.Width - m_sCurOffset - m_sScalevalue_H * (Picture1.Width / m_sScaleMax_H)
        Else
            If iKey And MK_SHIFT Then
                m_sScalevalue_V = m_sScalevalue_V + iDir * m_sScaleMultiplier_V
            Else
                 m_sScalevalue_V = m_sScalevalue_V + iDir
            End If
            
            If m_sScalevalue_V <= m_sScaleMin_V Then m_sScalevalue_V = m_sScaleMin_V
            If m_sScalevalue_V >= m_sScaleMax_V Then m_sScalevalue_V = m_sScaleMax_V
        
            Picture2.Top = Picture1.Top + Picture1.Height - m_sCurOffset - m_sScalevalue_V * (Picture1.Height / m_sScaleMax_V)
        End If
        
    Case Text1.hwnd
        If iKey And MK_CONTROL Then
            m_lSamplevalue = m_lSamplevalue + m_lWalkWay * iDir * m_lMutiplier_Large
            
        ElseIf iKey And MK_SHIFT Then
            m_lSamplevalue = m_lSamplevalue + m_lWalkWay * iDir * m_lMutiplier_Small
            
        Else
            m_lSamplevalue = m_lSamplevalue + m_lWalkWay * iDir
            
        End If
        
        Text1 = Trim(Str(m_lSamplevalue))
    
End SelectEnd Sub
Sub initialize()
Dim i As Integer
    m_blnWheelPresent = GetSystemMetrics(SM_MOUSEWHEELPRESENT)Picture1.Move 240, 240, 3015, 1935
Picture1.ScaleMode = vbPixels
Picture1.AutoRedraw = True
For i = 255 To 0 Step -1
    Picture1.Line ((Picture1.ScaleWidth / 255) * i, (Picture1.ScaleHeight / 255) * i)- _
                  (Picture1.ScaleWidth, Picture1.ScaleHeight), _
                   RGB(i, i / 2, i / 2), B
Next iWith Picture2
    .AutoRedraw = True
    .Appearance = 0
    .BorderStyle = 0
    .BackColor = &H8000000F
    .ScaleMode = vbPixels
    .Height = 225
    .Left = Picture1.Left + Picture1.Width
    .Width = 225
End With
With Picture3
    .AutoRedraw = True
    .Appearance = 0
    .BorderStyle = 0
    .BackColor = &H8000000F
    .ScaleMode = vbPixels
    .Height = 225
    .Top = Picture1.Top + Picture1.Height
    .Width = 225
End WithFor i = 0 To 7
    Picture2.Line (i, 7 - i)-(i, 7 + i)
    Picture3.Line (7 - i, i)-(7 + i, i)
Next i
    
    m_sScaleMultiplier_H = 10
    m_sScaleMax_H = 150
    m_sScaleMin_H = 0
    m_sScalevalue_H = m_sScaleMax_H / 2
    
    m_sScaleMultiplier_V = 10
    m_sScaleMax_V = 100
    m_sScaleMin_V = 0
    m_sScalevalue_V = m_sScaleMax_V / 2
    Picture2.Top = Picture1.Top + Picture1.Height - m_sCurOffset - m_sScalevalue_V * (Picture1.Height / m_sScaleMax_V)
    Picture3.Left = Picture1.Left + Picture1.Width - m_sCurOffset - m_sScalevalue_H * (Picture1.Width / m_sScaleMax_H)
    m_lWalkWay = m_WheelForward
    m_lMutiplier_Small = 10
    m_lMutiplier_Large = 100
    m_lSamplevalue = 100
    
    Text1.Move 3720, 240
    Text1 = Trim(Str(m_lSamplevalue))Picture1.ToolTipText = "Ctrl = Scroll Horizontal  Shift = 10x speed "
Text1.ToolTipText = "Click to enable   Ctrl = 100x   Shift = 10x   Return to validate Keyboad value entry"
End Sub
Private Sub Form_Click()
m_blnKeepSpinnig = False
DoEvents
End Sub
Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
m_blnKeepSpinnig = False
DoEvents
If m_blnWheelPresent Then
    If Not m_blnWheelTracking Then Call WatchForWheel(Picture1.hwnd)
End If
End Sub
Private Sub Text1_Click()If m_blnWheelPresent Then
    If Not m_blnWheelTracking Then Call WatchForWheel(Text1.hwnd, False)
End If
End Sub
Private Sub Text1_KeyPress(KeyAscii As Integer)If KeyAscii = vbKeyReturn Then KeyAscii = 0
End Sub
Private Sub Text1_KeyUp(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyReturn Then
        On Error Resume Next
            m_lSamplevalue = CLng(Text1.Text)
    End If
End Sub
Private Sub Text1_LostFocus()
m_blnKeepSpinnig = False
DoEvents
End Sub
Private Sub Form_Load()
initialize
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
m_blnKeepSpinnig = False
m_blnWheelTracking = False
     DoEvents
End Sub
Private Sub Form_Unload(Cancel As Integer)
m_blnKeepSpinnig = False
m_blnWheelTracking = False
     DoEvents
End Sub