excel 窗体上的ListBox滚动事件

sczxawaw 于 2023-05-08 发布在其他

关注(0)|答案(2)|浏览(345)

我在一个窗体上有两个并排的列表框，它们模拟Excel屏幕，左侧冻结在适当的位置。
第一个列表框将显示销售日期和客户名称。
第二个列表框将显示各种详细信息，因此可以水平滚动，而不会让客户名称看不见。
我设法使ListBox1.TopIndex = ListBox2.TopIndex。但只有当我点击它，选择一个项目，或移动鼠标在它上面时，才会发生这种情况。简而言之，使用任何可用的事件来激活该命令行。
我需要每当用户向上或向下滚动列表框时发生这种情况，但没有滚动事件。
现在，当我向下滚动listbox2时，listbox1保持静止。当我单击listbox2上的项目时，listbox1会刷新并与之对齐。

excel

来源：https://stackoverflow.com/questions/72999647/listbox-scroll-event-on-form

2条答案

按热度按时间

h7wcgrx31#

Windows API在VBA中仍然非常有用，可以满足更复杂项目的需求。要在列表框中获取滚动条，请使用以下代码（适用于Excel 32位）。我只是警告说，使用“Windows挂钩”可能会带来意想不到的或不可预见的不稳定性，有必要评估是否适合在给定的项目中使用此资源。
在ListBox中移动所选内容的代码是“MouseProc”。其他的处理从/到Windows到Userform/ListBox的消息的拦截，以及何时开始或结束这些拦截（Hook/Unhook）。

'Put or edit these events on the UserForm:
 
Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    fnHookListBoxScroll
End Sub
Private Sub UserForm_Deactivate()
    fnUnhookListBoxScroll
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    fnUnhookListBoxScroll
End Sub
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Put these codes on a standard module:

Option Explicit

Private Type POINTAPI
    X As Long
    Y As Long
End Type

Private Type MOUSEHOOKSTRUCT
    pt As POINTAPI
    hwnd As Long
    wHitTestCode As Long
    dwExtraInfo As Long
End Type

Private Declare Function GetWindowLong Lib "user32.dll" _
    Alias "GetWindowLongA" ( _
    ByVal hwnd As Long, _
    ByVal nIndex As Long) As Long

Private Declare Function SetWindowsHookEx Lib "user32" _
    Alias "SetWindowsHookExA" ( _
    ByVal idHook As Long, _
    ByVal lpfn As Long, _
    ByVal hmod As Long, _
    ByVal dwThreadId As Long) As Long

Private Declare Function CallNextHookEx Lib "user32" ( _
    ByVal hHook As Long, _
    ByVal nCode As Long, _
    ByVal wParam As Long, _
    lParam As Any) As Long

Private Declare Function UnhookWindowsHookEx Lib "user32" ( _
    ByVal hHook As Long) As Long

Private Declare Function PostMessage Lib "user32.dll" _
    Alias "PostMessageA" ( _
    ByVal hwnd As Long, _
    ByVal wMsg As Long, _
    ByVal wParam As Long, _
    ByVal lParam As Long) As Long

Private Declare Function WindowFromPoint Lib "user32" ( _
    ByVal xPoint As Long, _
    ByVal yPoint As Long) As Long

Private Declare Function GetCursorPos Lib "user32.dll" ( _
    ByRef lpPoint As POINTAPI) As Long

Private Const WH_MOUSE_LL As Long = 14
Private Const WM_MOUSEWHEEL As Long = &H20A
Private Const HC_ACTION As Long = 0
Private Const GWL_HINSTANCE As Long = (-6)

Private Const WM_KEYDOWN As Long = &H100
Private Const WM_KEYUP As Long = &H101
Private Const VK_UP As Long = &H26
Private Const VK_DOWN As Long = &H28
Private Const WM_LBUTTONDOWN As Long = &H201

Private mLngMouseHook As Long
Private mListBoxHwnd As Long
Private mbHook As Boolean

Sub fnHookListBoxScroll()
    Dim lngAppInst As Long
    Dim hwndUnderCursor As Long
    Dim tPT As POINTAPI
    
    GetCursorPos tPT
    DoEvents
    hwndUnderCursor = WindowFromPoint(tPT.X, tPT.Y)
    DoEvents
    If mListBoxHwnd <> hwndUnderCursor Then
        fnUnhookListBoxScroll
        DoEvents
        mListBoxHwnd = hwndUnderCursor
        DoEvents
        lngAppInst = GetWindowLong(mListBoxHwnd, GWL_HINSTANCE)
        DoEvents
        PostMessage mListBoxHwnd, WM_LBUTTONDOWN, 0&, 0&
        DoEvents
        If Not mbHook Then
            mLngMouseHook = SetWindowsHookEx( _
                WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0)
            DoEvents
            mbHook = mLngMouseHook <> 0
            DoEvents
        End If
        DoEvents
    End If
    DoEvents
End Sub

Sub fnUnhookListBoxScroll()
    If mbHook Or mLngMouseHook = 0 Then
        UnhookWindowsHookEx mLngMouseHook
        mLngMouseHook = 0
        mListBoxHwnd = 0
        mbHook = False
    End If
End Sub

Private Function MouseProc( _
    ByVal nCode As Long, ByVal wParam As Long, _
    ByRef lParam As MOUSEHOOKSTRUCT) As Long
    On Error GoTo errH 'Resume Next
    If (nCode = HC_ACTION) Then
        If WindowFromPoint(lParam.pt.X, lParam.pt.Y) = mListBoxHwnd Then
            If wParam = WM_MOUSEWHEEL Then
                MouseProc = True
                If lParam.hwnd > 0 Then
                    PostMessage mListBoxHwnd, WM_KEYDOWN, VK_UP, 0
                    DoEvents
                Else
                    PostMessage mListBoxHwnd, WM_KEYDOWN, VK_DOWN, 0
                    DoEvents
                End If
                PostMessage mListBoxHwnd, WM_KEYUP, VK_UP, 0
                DoEvents
                Exit Function
            End If
        Else
            fnUnhookListBoxScroll
        End If
    End If
    MouseProc = CallNextHookEx( _
        mLngMouseHook, nCode, wParam, ByVal lParam)
    Exit Function
errH:
    fnUnhookListBoxScroll
End Function

重要提示：

如果您使用Excel 64位（在64位Windows下），则可以使用以下代码：
在其他重要的变化中，不仅对“声明”，而且对代码本身，请注意POINTAPI类型的剧烈变化。有必要创建一个专用函数来正确传递相应的数据。

'Put or edit these events on the UserForm:
    Option Explicit
    
    Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
        fnHookListBoxScroll
    End Sub
    
    Private Sub UserForm_Deactivate()
        fnUnhookListBoxScroll
    End Sub
    
    Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
        fnUnhookListBoxScroll
    End Sub
    '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    'Put these codes on a standard module:
    
    Option Explicit
    
    
    Public Type POINTAPI
        x As Long
        Y As Long
    End Type
    
    Private Type MOUSEHOOKSTRUCT
        pt As POINTAPI
        hwnd As Long
        wHitTestCode As Long
        dwExtraInfo As Long
    End Type
    
    Private Declare PtrSafe Function GetWindowLong Lib "user32.dll" _
        Alias "GetWindowLongA" ( _
        ByVal hwnd As LongPtr, _
        ByVal nIndex As Long) As Long
    
    Declare PtrSafe Function SetWindowsHookEx Lib "user32" _
        Alias "SetWindowsHookExA" ( _
        ByVal idHook As Long, _
        ByVal lpfn As LongPtr, _
        ByVal hmod As LongPtr, _
        ByVal dwThreadId As Long) As LongPtr
    
    Declare PtrSafe Function CallNextHookEx Lib "user32" _
        ( _
        ByVal hHook As LongPtr, _
        ByVal ncode As Long, _
        ByVal wParam As LongPtr, _
        lParam As Any) As LongPtr
    
    Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" ( _
        ByVal hhk As LongPtr) As Long
    
    Declare PtrSafe Function PostMessage Lib "user32" Alias _
        "PostMessageA" (ByVal hwnd As LongPtr, _
        ByVal wMsg As Long, _
        ByVal wParam As LongPtr, _
        ByVal lParam As LongPtr) As Long
    
    Declare PtrSafe Function WindowFromPoint Lib "user32" _
        ( _
        ByVal Point As LongLong) As LongPtr
    
    Declare PtrSafe Function GetCursorPos Lib "user32" _
        (lpPoint As POINTAPI) As Long
        
    Declare PtrSafe Sub CopyMemory Lib "kernel32" _
        Alias "RtlMoveMemory" ( _
        Destination As Any, _
        Source As Any, _
        ByVal Length As LongPtr)
    
    Private Const WH_MOUSE_LL As Long = 14
    Private Const WM_MOUSEWHEEL As Long = &H20A
    Private Const HC_ACTION As Long = 0
    Private Const GWL_HINSTANCE As Long = (-6)
    
    Private Const WM_KEYDOWN As Long = &H100
    Private Const WM_KEYUP As Long = &H101
    Private Const VK_UP As Long = &H26
    Private Const VK_DOWN As Long = &H28
    Private Const WM_LBUTTONDOWN As Long = &H201
    
    Private mLngMouseHook As LongPtr
    Private mListBoxHwnd As LongPtr
    Private mbHook As Boolean
    
    ' Copies a POINTAPI into a LongLong.  For an API requiring a ByVal POINTAPI parameter,
    ' this LongLong can be passed in instead.  Example API's include WindowFromPoint,
    ' ChildWindowFromPoint, ChildWindowFromPointEx, DragDetect, and MenuItemFromPoint.
    Function PointToLongLong(Point As POINTAPI) As LongLong
        Dim ll As LongLong
        Dim cbLongLong As LongPtr
        
        cbLongLong = LenB(ll)
        
        ' make sure the contents will fit
        If LenB(Point) = cbLongLong Then
            CopyMemory ll, Point, cbLongLong
        End If
        
        PointToLongLong = ll
    End Function
    
    Sub fnHookListBoxScroll()
        Dim lngAppInst As Long
        Dim hwndUnderCursor As LongPtr
        Dim tPT As POINTAPI
        
        GetCursorPos tPT
        DoEvents
        hwndUnderCursor = WindowFromPoint(PointToLongLong(tPT))
        DoEvents
        If mListBoxHwnd <> hwndUnderCursor Then
            fnUnhookListBoxScroll
            DoEvents
            mListBoxHwnd = hwndUnderCursor
            DoEvents
            lngAppInst = GetWindowLong(mListBoxHwnd, GWL_HINSTANCE)
            DoEvents
            PostMessage mListBoxHwnd, WM_LBUTTONDOWN, 0&, 0&
            DoEvents
            If Not mbHook Then
                mLngMouseHook = SetWindowsHookEx( _
                    WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0)
                DoEvents
                mbHook = mLngMouseHook <> 0
                DoEvents
            End If
            DoEvents
        End If
        DoEvents
    End Sub
    
    Sub fnUnhookListBoxScroll()
        If mbHook Or mLngMouseHook = 0 Then
            UnhookWindowsHookEx mLngMouseHook
            mLngMouseHook = 0
            mListBoxHwnd = 0
            mbHook = False
        End If
    End Sub
    
    Private Function MouseProc( _
        ByVal ncode As Long, ByVal wParam As Long, _
        ByRef lParam As MOUSEHOOKSTRUCT) As LongPtr
        On Error GoTo errH 'Resume Next
        If (ncode = HC_ACTION) Then
            If WindowFromPoint(PointToLongLong(lParam.pt)) = mListBoxHwnd Then
                If wParam = WM_MOUSEWHEEL Then
                    MouseProc = True
                    If lParam.hwnd > 0 Then
                        PostMessage mListBoxHwnd, WM_KEYDOWN, VK_UP, 0
                        DoEvents
                    Else
                        PostMessage mListBoxHwnd, WM_KEYDOWN, VK_DOWN, 0
                        DoEvents
                    End If
                    PostMessage mListBoxHwnd, WM_KEYUP, VK_UP, 0
                    DoEvents
                    Exit Function
                End If
            Else
                fnUnhookListBoxScroll
            End If
        End If
        MouseProc = CallNextHookEx( _
            mLngMouseHook, ncode, wParam, ByVal lParam)
        Exit Function
    errH:
        fnUnhookListBoxScroll
    End Function

赞(0）回复(0）举报 2023-05-08

dced5bon2#

这里有一个简单的选择（当我有同样的问题时，我没有立即想到）是使用一个单独的ScrollBar控件，其事件连接到两个ListBox控件。
你必须弄清楚如何连接所有的东西，这可能取决于列表框是否会显示一定数量的项目或可扩展。但是，它有所有的事件。

赞(0）回复(0）举报 2023-05-08