Question

我在网上找到了以下代码（不记得在哪里），它允许鼠标滚轮通过API调用在我的Userform的ComboBoxes中运行;代码完美地用于此目的。我遇到的问题是他们称之为“取消”鼠标，或将鼠标滚轮返回到常规默认操作。目前我无法获取用于取消鼠标工作的代码，并且它导致滚轮在Windows期间不起作用，除非我关闭整个Excel应用程序。有人可以请进来帮我解决这个问题吗？

常规模块代码：

Option Explicit

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

Declare Function GetForegroundWindow Lib "user32" () As Long

Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)

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

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

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

Type POINTAPI
  X As Long
  Y As Long
End Type

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

Const HC_ACTION = 0
Const WH_MOUSE_LL = 14
Const WM_MOUSEWHEEL = &H20A

Dim hhkLowLevelMouse, lngInitialColor As Long
Dim udtlParamStuct As MSLLHOOKSTRUCT
Public intTopIndex As Integer

'==========================================================================
'\\Copy the Data from lParam of the Hook Procedure argument to our Struct
Function GetHookStruct(ByVal lParam As Long) As MSLLHOOKSTRUCT

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
On Error Resume Next

If (nCode = HC_ACTION) Then

    If wParam = WM_MOUSEWHEEL Then

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

            '\\ Change this to your userform name
            With SkillChange_Begin.Controls(Worksheets("Skill Change Detail").Range("AV2").Value)

          '\\ if rolling forward increase Top index by 1 to cause an Up Scroll
            If GetHookStruct(lParam).mouseData > 0 Then

                .TopIndex = intTopIndex - 1

                '\\ Store new TopIndex value
                intTopIndex = .TopIndex

            Else '\\ if rolling backward decrease Top index by 1 to cause _
            '\\a Down Scroll

                .TopIndex = intTopIndex + 1

                '\\ Store new TopIndex value
                intTopIndex = .TopIndex

            End If

       End With

    End If

    Exit Function

End If

LowLevelMouseProc = CallNextHookEx(0, nCode, wParam, ByVal lParam)
End Function
'=======================================================================
Sub Hook_Mouse()

hhkLowLevelMouse = SetWindowsHookEx _
(WH_MOUSE_LL, AddressOf LowLevelMouseProc, Application.Hinstance, 0)

End Sub

'========================================================================
Sub UnHook_Mouse()

If hhkLowLevelMouse <> 0 Then UnhookWindowsHookEx hhkLowLevelMouse

End Sub

Userform代码：

Private Sub Skill1_1_DropButtonClick()

Worksheets("Skill Change Detail").Range("AV2").Value = SkillChange_Begin.Frame31.ActiveControl.Name
intTopIndex = Skill1_1.TopIndex
Hook_Mouse

End Sub

 Private Sub UserForm_Terminate()

UnHook_Mouse

End Sub

Answer 1

在进一步研究这些API调用的内部工作原理后，我发现SetWindowsHookEx函数设置了一个钩子来监视鼠标的使用情况;此挂钩被视为数值。要删除此挂钩，必须使用免费的UnhookWindowsHookEx函数和初始挂钩期间使用SetWindowsHookEx函数指定的数值。没有办法知道这个数值（我可以弄清楚）以释放钩子，所以我只是设计了下面的简单代码，其中有诀窍：

Sub UnHook_Mouse()

Dim L1 As Long

For L1 = 1 To 10000
    UnhookWindowsHookEx L1
Next L1

End Sub

Answer 2

您没有使用更好的解决方案的主要原因是您正在使用全局低级钩子（附加到所有线程）。最好的处理方法是使用本地钩子（仅适用于当前线程）。有关完整的解决方案，请参见Github存储库：https://github.com/cristianbuse/VBA-UserForm-MouseScroll（是的，我是作者）。享受吧！

从Userform取消挂钩滚轮

2 个答案: