从用户窗体中解开滚轮

Question

我在网上找到了下面的代码（不记得在哪里），它允许鼠标滚轮通过 API 调用在我的用户窗体的组合框中运行；该代码非常适合该目的。我遇到的问题是他们所说的 "Unhooking" 鼠标，或将鼠标滚轮返回到常规默认操作。目前，我无法获得用于脱开鼠标的代码位，它会导致滚轮在 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

用户表单代码：

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

从用户窗体中解开滚轮

UnHook Scroll Wheel from Userform

excel

vba

combobox

mousewheel

userform