鼠标滚动列表框

Question

我正在使用Peter Thornton的这个代码，它允许我滚动一个用户窗体列表框，但每次我的鼠标通过列表框（只是将光标移动到用户窗体的另一部分，甚至没有点击）它“激活” “列表框。有什么方法可以“阻止”这种情况发生吗？我的意思是，只有当我点击向下箭头打开列表框时，鼠标滚动才能起作用？

这是Peter Thronton的代码：

'''''' normal module code

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 FindWindow Lib "user32" _
                                        Alias "FindWindowA" ( _
                                                        ByVal lpClassName As String, _
                                                        ByVal lpWindowName As String) As Long

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
Private mCtl As MSForms.Control
Dim n As Long

Sub HookListBoxScroll(frm As Object, ctl As MSForms.Control)
Dim lngAppInst As Long
Dim hwndUnderCursor As Long
Dim tPT As POINTAPI
     GetCursorPos tPT
     hwndUnderCursor = WindowFromPoint(tPT.X, tPT.Y)
     If Not frm.ActiveControl Is ctl Then
             ctl.SetFocus
     End If
     If mListBoxHwnd <> hwndUnderCursor Then
             UnhookListBoxScroll
             Set mCtl = ctl
             mListBoxHwnd = hwndUnderCursor
             lngAppInst = GetWindowLong(mListBoxHwnd, GWL_HINSTANCE)
             ' PostMessage mListBoxHwnd, WM_LBUTTONDOWN, 0&, 0&
             If Not mbHook Then
                     mLngMouseHook = SetWindowsHookEx( _
                                                     WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0)
                     mbHook = mLngMouseHook <> 0
             End If
     End If
End Sub

Sub UnhookListBoxScroll()
     If mbHook Then
                Set mCtl = Nothing
             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
Dim idx As Long
        On Error GoTo errH
     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
'                                Else
'                                        PostMessage mListBoxHwnd, WM_KEYDOWN, VK_DOWN, 0
'                                End If
'                                PostMessage mListBoxHwnd, WM_KEYUP, VK_UP, 0
                                If lParam.hwnd > 0 Then idx = -1 Else idx = 1
'                             idx = idx + mCtl.ListIndex
'                             If idx >= 0 Then mCtl.ListIndex = idx
                             idx = idx + mCtl.TopIndex
                             If idx >= 0 Then mCtl.TopIndex = idx
                                Exit Function
                     End If
             Else
                     UnhookListBoxScroll
             End If
     End If
     MouseProc = CallNextHookEx( _
                             mLngMouseHook, nCode, wParam, ByVal lParam)
     Exit Function
errH:
     UnhookListBoxScroll
End Function
'''''''' end normal module code

Answer 1

这将起作用=）

Option Explicit

'This will compile in 32 bit Excel only

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
                            (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long

Private Declare Function GetForegroundWindow Lib "user32" () As Long

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
                       (ByVal Destination As Long, ByVal Source As Long, ByVal Length 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 Type POINTAPI
  x As Long
  Y As Long
End Type

Private Type MSLLHOOKSTRUCT  'Will Hold the lParam struct Data
  pt As POINTAPI
  mouseData As Long  ' Holds Forward\Backward flag
  flags As Long
  time As Long
  dwExtraInfo As Long
End Type

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

Public Const nMyControlTypeNONE = 0
Public Const nMyControlTypeUSERFORM = 1
Public Const nMyControlTypeFRAME = 2
Public Const nMyControlTypeCOMBOBOX = 3
Public Const nMyControlTypeLISTBOX = 4

Private hhkLowLevelMouse As Long
Private udtlParamStuct As MSLLHOOKSTRUCT

Public myGblUserForm As UserForm
Public myGblControlObject As Object
Public iGblControlType As Integer

Public myGblUserFormControl As Object

Function GetHookStruct(ByVal lParam As Long) As MSLLHOOKSTRUCT
' VarPtr returns address; LenB returns size in bytes.
  CopyMemory VarPtr(udtlParamStuct), lParam, LenB(udtlParamStuct)
  GetHookStruct = udtlParamStuct
End Function

Function LowLevelMouseProc _
         (ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

  'Avoid XL crashing if RunTime error occurs due to Mouse fast movement

  Dim iDirection As Long

  On Error Resume Next
  '    \\ Unhook & get out in case the application is deactivated
  If GetForegroundWindow <> FindWindow("ThunderDFrame", myGblUserForm.Caption) Then
    UnHook_Mouse
    Exit Function
  End If
  If (nCode = HC_ACTION) Then
    If wParam = WM_MOUSEWHEEL Then

      iDirection = GetHookStruct(lParam).mouseData
      Call ProcessMouseWheelMovement(iDirection)

      '\\ Don't process Default WM_MOUSEWHEEL Window message
      LowLevelMouseProc = True
    End If

    Exit Function
  End If
  LowLevelMouseProc = CallNextHookEx(0, nCode, wParam, ByVal lParam)
End Function

Sub Hook_Mouse()
' Statement to maintain the handle of the hook if clicking outside of the control.
' There isn't a Hinstance for Application, so used GetWindowLong to get handle.
  If hhkLowLevelMouse < 1 Then
    hhkLowLevelMouse = SetWindowsHookEx(WH_MOUSE_LL, AddressOf LowLevelMouseProc, _
      GetWindowLong(FindWindow("ThunderDFrame", myGblUserForm.Caption), GWL_HINSTANCE), 0)
  End If
End Sub

Sub UnHook_Mouse()
  If hhkLowLevelMouse <> 0 Then
    UnhookWindowsHookEx hhkLowLevelMouse
    hhkLowLevelMouse = 0
  End If
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'UserForm MouseWheel Code
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub ProcessMouseWheelMovement(ByVal iDirection As Long)
  'This processes MouseWheel Scrolls
  '
  'Thank You Mathieu Plante from July 2004

  Dim i As Long
  Dim iMultiplier As Long

  'Debug.Print iDirection, iGblControlType, Now()


  Select Case iGblControlType


    ''''''''''''''''''''''''''''''''''''''''''''''''
    'UserForm Mouse Scroll
    ''''''''''''''''''''''''''''''''''''''''''''''''
    Case nMyControlTypeUSERFORM

      iMultiplier = 3

      If iDirection > 0 Then

        For i = 1 To iMultiplier
          myGblControlObject.Scroll fmScrollActionNoChange, fmScrollActionLineUp
        Next i
      Else
        For i = 1 To iMultiplier
          myGblControlObject.Scroll fmScrollActionNoChange, fmScrollActionLineDown
        Next i
      End If


    ''''''''''''''''''''''''''''''''''''''''''''''''
    'Frame Mouse Scroll
    ''''''''''''''''''''''''''''''''''''''''''''''''
    Case nMyControlTypeFRAME

      iMultiplier = 5

      If iDirection > 0 Then

        For i = 1 To iMultiplier
          myGblControlObject.Scroll fmScrollActionNoChange, fmScrollActionLineUp
        Next i
      Else
        For i = 1 To iMultiplier
          myGblControlObject.Scroll fmScrollActionNoChange, fmScrollActionLineDown
        Next i
      End If


    ''''''''''''''''''''''''''''''''''''''''''''''''
    'ComboBox Mouse Scroll
    ''''''''''''''''''''''''''''''''''''''''''''''''
    Case nMyControlTypeCOMBOBOX

      With myGblControlObject
        '\\ if rolling forward increase Top index by 1 to cause an Up Scroll
        If iDirection > 0 Then
          .TopIndex = .TopIndex - 1
        Else  '\\ if rolling backward decrease Top index by 1 to cause a Down Scroll
          .TopIndex = .TopIndex + 1
        End If
      End With
      'Debug.Print "Top Index = " & myGblControlObject.TopIndex

    ''''''''''''''''''''''''''''''''''''''''''''''''
    'Listbox Mouse Scroll
    ''''''''''''''''''''''''''''''''''''''''''''''''
    Case nMyControlTypeLISTBOX

      With myGblControlObject
        '\\ if rolling forward increase Top index by 1 to cause an Up Scroll
        If iDirection > 0 Then
          .TopIndex = .TopIndex - 1
        Else  '\\ if rolling backward decrease Top index by 1 to cause a Down Scroll
          .TopIndex = .TopIndex + 1
        End If
      End With
      'Debug.Print "Top Index = " & myGblControlObject.TopIndex

  End Select

End Sub

来自Excel论坛的LJMetzer。