表单上的ListBox滚动事件

问题描述 投票：0回答：3

我在表单上有两个并排的列表框，它们模拟 Excel 屏幕，左侧冻结在适当的位置。
第一个列表框将显示销售日期和客户名称。
第二个列表框将显示各种详细信息，因此可以水平滚动，而客户名称不会消失。

我设法使ListBox1.TopIndex = ListBox2.TopIndex。但只有当我单击它、选择一个项目或将鼠标移到它上面时才会发生这种情况。简而言之，使用任何可用的事件来激活该命令行。

每当用户向上或向下滚动列表框但没有滚动事件时，我都需要发生这种情况。

现在，当我向下滚动 listbox2 时，listbox1 保持静止。当我单击 listbox2 上的某个项目时，listbox1 会刷新并与其对齐。

excel vba forms events scroll
3个回答
1
投票

Windows API 在 VBA 中仍然非常有用，可以满足更复杂项目的需求。要在列表框中滚动，请使用以下代码（对于 Excel 32 位）。我只是警告说，使用“Windows 挂钩”可能会带来意外或不可预见的不稳定，有必要评估在给定项目中使用此资源是否合适。

在列表框中移动选择的代码是“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
投票

这里的一个简单选项（但当我遇到同样的问题时我没有立即想到）是使用单独的 ScrollBar 控件，其事件连接到两个 ListBox 控件。

您必须弄清楚如何连接所有内容，这可能取决于列表框是否显示一定数量的项目或可扩展。然而，它拥有所有事件。

0
投票

我的 Excel 应该有什么配置才能使代码正常工作？因为复制和粘贴会损坏文件并自动关闭并损坏

最新问题
© www.soinside.com 2019 - 2024. All rights reserved.