鼠标滚动在用户窗体中不起作用 VBA
Mouse scrolling is not working in userform VBA
我创建了用户窗体,它的高度超过了可以在显示器上显示的高度。我想准备我的用户表单更“用户友好”
- 身高:612
- KeepScrollBarsVisable - 0 - fmScrollBarsNone
- 滚动条 - 2 - fmScrollBarsVerdical
- ScrollHeight: 1100(如果我增加这个数字,显示 space
(身高)也多)
- ScrollTop 和 Left: 0
- 顶部:0
- Excel 2016.
为什么我不能使用鼠标滚动上下滚动表单?只有单击左侧滚动框才能显示更多内容。
顺便提一句。此滚动框由 ScrollBars 属性自动添加。
你能支持我吗,怎么了?谢谢
用户表单本身不支持鼠标滚轮滚动 (AFAIK)
我 post 代码在这里,所以 64 位答案可用。
步骤:
1- 在用户窗体后面添加此代码:
Private Sub UserForm_Initialize()
HookFormScroll Me
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
UnhookFormScroll
End Sub
将以下内容之一添加到Module
If Office is on 32 bit:
Option Explicit
' Based on code from Peter Thornton here:
' http://social.msdn.microsoft.com/Forums/en-US/7d584120-a929-4e7c-9ec2-9998ac639bea/mouse-scroll-in-userform-listbox-in-excel-2010?forum=isvvba
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 Const cSCROLLCHANGE As Long = 10
Private mLngMouseHook As Long
Private mFormHwnd As Long
Private mbHook As Boolean
Dim mForm As Object
Sub HookFormScroll(oForm As Object)
Dim lngAppInst As Long
Dim hwndUnderCursor As Long
Set mForm = oForm
hwndUnderCursor = FindWindow("ThunderDFrame", oForm.Caption)
Debug.Print "Form window: " & hwndUnderCursor
If mFormHwnd <> hwndUnderCursor Then
UnhookFormScroll
Debug.Print "Unhook old proc"
mFormHwnd = hwndUnderCursor
lngAppInst = GetWindowLong(mFormHwnd, GWL_HINSTANCE)
If Not mbHook Then
mLngMouseHook = SetWindowsHookEx( _
WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0)
mbHook = mLngMouseHook <> 0
If mbHook Then Debug.Print "Form hooked"
End If
End If
End Sub
Sub UnhookFormScroll()
If mbHook Then
UnhookWindowsHookEx mLngMouseHook
mLngMouseHook = 0
mFormHwnd = 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
Debug.Print "action"
Debug.Print "right window"
If wParam = WM_MOUSEWHEEL Then
Debug.Print "mouse scroll"
MouseProc = True
If lParam.hwnd > 0 Then
mForm.ScrollTop = Application.Max(0, mForm.ScrollTop - cSCROLLCHANGE)
Else
mForm.ScrollTop = Application.Min(mForm.ScrollHeight - mForm.InsideHeight, mForm.ScrollTop + cSCROLLCHANGE)
End If
Exit Function
End If
End If
MouseProc = CallNextHookEx( _
mLngMouseHook, nCode, wParam, ByVal lParam)
Exit Function
errH:
UnhookFormScroll
End Function
If Office is on 64 bit:
Option Explicit
' Based on code from Peter Thornton here:
' http://social.msdn.microsoft.com/Forums/en-US/7d584120-a929-4e7c-9ec2-9998ac639bea/mouse-scroll-in-userform-listbox-in-excel-2010?forum=isvvba
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 PtrSafe Function FindWindow Lib "user32" _
Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function GetWindowLong Lib "user32.dll" _
Alias "GetWindowLongA" ( _
ByVal hwnd As Long, _
ByVal nIndex As Long) As Long
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" _
Alias "SetWindowsHookExA" ( _
ByVal idHook As Long, _
ByVal lpfn As LongPtr, _
ByVal hmod As Long, _
ByVal dwThreadId As Long) As Long
Private Declare PtrSafe Function CallNextHookEx Lib "user32" ( _
ByVal hHook As Long, _
ByVal nCode As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" ( _
ByVal hHook As Long) As Long
Private Declare PtrSafe 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 PtrSafe Function WindowFromPoint Lib "user32" ( _
ByVal xPoint As Long, _
ByVal yPoint As Long) As Long
Private Declare PtrSafe 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 Const cSCROLLCHANGE As Long = 10
Private mLngMouseHook As Long
Private mFormHwnd As Long
Private mbHook As Boolean
Dim mForm As Object
Sub HookFormScroll(oForm As Object)
Dim lngAppInst As Long
Dim hwndUnderCursor As Long
Set mForm = oForm
hwndUnderCursor = FindWindow("ThunderDFrame", oForm.Caption)
Debug.Print "Form window: " & hwndUnderCursor
If mFormHwnd <> hwndUnderCursor Then
UnhookFormScroll
Debug.Print "Unhook old proc"
mFormHwnd = hwndUnderCursor
lngAppInst = GetWindowLong(mFormHwnd, GWL_HINSTANCE)
If Not mbHook Then
mLngMouseHook = SetWindowsHookEx( _
WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0)
mbHook = mLngMouseHook <> 0
If mbHook Then Debug.Print "Form hooked"
End If
End If
End Sub
Sub UnhookFormScroll()
If mbHook Then
UnhookWindowsHookEx mLngMouseHook
mLngMouseHook = 0
mFormHwnd = 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
Debug.Print "action"
Debug.Print "right window"
If wParam = WM_MOUSEWHEEL Then
Debug.Print "mouse scroll"
MouseProc = True
If lParam.hwnd > 0 Then
mForm.ScrollTop = Application.Max(0, mForm.ScrollTop - cSCROLLCHANGE)
Else
mForm.ScrollTop = Application.Min(mForm.ScrollHeight - mForm.InsideHeight, mForm.ScrollTop + cSCROLLCHANGE)
End If
Exit Function
End If
End If
MouseProc = CallNextHookEx( _
mLngMouseHook, nCode, wParam, ByVal lParam)
Exit Function
errH:
UnhookFormScroll
End Function
VBA 用户窗体(旧 Thunderframe)的 Window 不处理任何鼠标消息。您可以使用 Spy++ 快速测试它。不过鼠标是可以挂的
虽然@RicardoDiaz 提供了一个示例,但我应该提到他的钩子是全局的,这意味着您正在跨所有进程的所有线程跟踪鼠标消息。真的很慢而且看起来不流畅。相反,您可以使用本地挂钩(仅限本地线程)。
您可以使用我的存储库 VBA UserForm MouseScroll 中的代码,它适用于 x32 和 x64 版本。它还会滚动表单、框架、组合框、列表框等。也支持水平滚动和缩放。享受吧!
问题出在Excel,必须关闭Visual Basic编辑器!!! Excel->错误!!!
调用的正确代码
模块 1:
Option Explicit
Public Sub ShowModal()
UserForm1.Show vbModal
End Sub
Public Sub ShowModeless()
UserForm1.Show vbModeless
End Sub
模块 2:
Option Explicit
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 WHEEL_DOWN As LongPtr = 7864320
Private Const WHEEL_UP As LongPtr = 4287102976#
Private 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
Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal nCode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As LongPtr
Private Declare PtrSafe Function GetCursorPos Lib "user32" (ByRef lpPoint As POINTAPI) As LongPtr
Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As LongLong) As LongPtr '
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
Private Type POINTAPI
XY As LongLong
End Type
Private Type MOUSEHOOKSTRUCT
pt As POINTAPI
hwnd As LongPtr
wHitTestCode As Long '????
dwExtraInfo As LongPtr
End Type
Private HookPtr As LongPtr, EventControl As Object, EventPtr As LongPtr
'------------------
'Hook, Proc, UnHook
'------------------
Public Sub HookControl(NewEventControl As Object)
If HookPtr = 0 Then
Set EventControl = NewEventControl
EventControl.BackColor = vbRed 'Test
EventPtr = CurserPtr
HookPtr = SetWindowsHookEx(WH_MOUSE_LL, AddressOf MouseProc, FormPtr, 0)
End If
End Sub
Private Function MouseProc(ByVal nCode As Long, ByVal wParam As LongPtr, ByRef lParam As MOUSEHOOKSTRUCT) As LongPtr
On Error GoTo 1
MouseProc = CallNextHookEx(HookPtr, nCode, wParam, ByVal lParam)
Dim WheelScrool As Variant
Select Case True
Case EventControl Is Nothing: UnHookControl
Case EventPtr <> CurserPtr: UnHookControl
Case HookPtr = 0
Case nCode <> HC_ACTION
Case wParam <> WM_MOUSEWHEEL
Case lParam.hwnd = WHEEL_DOWN: WheelScrool = EventControl.ListIndex - 1
Case lParam.hwnd = WHEEL_UP: WheelScrool = EventControl.ListIndex + 1
End Select
If Not IsEmpty(WheelScrool) Then
WheelScrool = IIf(WheelScrool < 0, 0, WheelScrool)
WheelScrool = IIf(WheelScrool > EventControl.ListCount - 1, EventControl.ListCount - 1, WheelScrool)
If EventControl.BackColor <> vbYellow Then EventControl.BackColor = vbYellow 'Test
EventControl.ListIndex = WheelScrool
End If
Exit Function
1: UnHookControl
End Function
Public Sub UnHookControl()
If HookPtr <> 0 Then
UnhookWindowsHookEx HookPtr
HookPtr = 0
EventControl.BackColor = vbGreen 'Test
Set EventControl = Nothing
End If
End Sub
'---------------------------
'Status query (not required)
'---------------------------
Public Property Get IsHookControl() As Boolean
IsHookControl = (HookPtr <> 0)
End Property
'------------------
'Pointer Functionen
'------------------
Public Function CurserPtr() As LongPtr
Dim tPT As POINTAPI: GetCursorPos tPT
CurserPtr = WindowFromPoint(tPT.XY)
End Function
Private Function FormPtr() As LongPtr
Dim fHw As LongPtr: fHw = FindWindow("ThunderDFrame", EventControl.Parent.Caption)
FormPtr = GetWindowLong(fHw, GWL_HINSTANCE)
End Function
用户表单:
'-----------------------------
'Elemente:
' ComboBox1
' ListBox1
' ListBox2
'-----------------------------
Option Explicit
Private ActControl As Object
'---------
'User Form
'---------
Private Sub UserForm_Initialize()
Dim i As Long
For i = 10 To 30
ListBox1.AddItem i & " - ListBox1"
ListBox2.AddItem i & " - ListBox2"
ComboBox1.AddItem i & " - ComboBox1"
Next
ComboBox1.ListIndex = 0
End Sub
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
UnHookControl
End Sub
'----------------------------
'CombBox1, ListBox1, ListBox2
'----------------------------
Private Sub ComboBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
HookControl ComboBox1
End Sub
Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
HookControl ListBox1
End Sub
Private Sub ListBox2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
HookControl ListBox2
End Sub
我创建了用户窗体,它的高度超过了可以在显示器上显示的高度。我想准备我的用户表单更“用户友好”
- 身高:612
- KeepScrollBarsVisable - 0 - fmScrollBarsNone
- 滚动条 - 2 - fmScrollBarsVerdical
- ScrollHeight: 1100(如果我增加这个数字,显示 space (身高)也多)
- ScrollTop 和 Left: 0
- 顶部:0
- Excel 2016.
为什么我不能使用鼠标滚动上下滚动表单?只有单击左侧滚动框才能显示更多内容。 顺便提一句。此滚动框由 ScrollBars 属性自动添加。
你能支持我吗,怎么了?谢谢
用户表单本身不支持鼠标滚轮滚动 (AFAIK)
我 post 代码在这里,所以 64 位答案可用。
步骤:
1- 在用户窗体后面添加此代码:
Private Sub UserForm_Initialize()
HookFormScroll Me
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
UnhookFormScroll
End Sub
将以下内容之一添加到
Module
If Office is on 32 bit:
Option Explicit
' Based on code from Peter Thornton here:
' http://social.msdn.microsoft.com/Forums/en-US/7d584120-a929-4e7c-9ec2-9998ac639bea/mouse-scroll-in-userform-listbox-in-excel-2010?forum=isvvba
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 Const cSCROLLCHANGE As Long = 10
Private mLngMouseHook As Long
Private mFormHwnd As Long
Private mbHook As Boolean
Dim mForm As Object
Sub HookFormScroll(oForm As Object)
Dim lngAppInst As Long
Dim hwndUnderCursor As Long
Set mForm = oForm
hwndUnderCursor = FindWindow("ThunderDFrame", oForm.Caption)
Debug.Print "Form window: " & hwndUnderCursor
If mFormHwnd <> hwndUnderCursor Then
UnhookFormScroll
Debug.Print "Unhook old proc"
mFormHwnd = hwndUnderCursor
lngAppInst = GetWindowLong(mFormHwnd, GWL_HINSTANCE)
If Not mbHook Then
mLngMouseHook = SetWindowsHookEx( _
WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0)
mbHook = mLngMouseHook <> 0
If mbHook Then Debug.Print "Form hooked"
End If
End If
End Sub
Sub UnhookFormScroll()
If mbHook Then
UnhookWindowsHookEx mLngMouseHook
mLngMouseHook = 0
mFormHwnd = 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
Debug.Print "action"
Debug.Print "right window"
If wParam = WM_MOUSEWHEEL Then
Debug.Print "mouse scroll"
MouseProc = True
If lParam.hwnd > 0 Then
mForm.ScrollTop = Application.Max(0, mForm.ScrollTop - cSCROLLCHANGE)
Else
mForm.ScrollTop = Application.Min(mForm.ScrollHeight - mForm.InsideHeight, mForm.ScrollTop + cSCROLLCHANGE)
End If
Exit Function
End If
End If
MouseProc = CallNextHookEx( _
mLngMouseHook, nCode, wParam, ByVal lParam)
Exit Function
errH:
UnhookFormScroll
End Function
If Office is on 64 bit:
Option Explicit
' Based on code from Peter Thornton here:
' http://social.msdn.microsoft.com/Forums/en-US/7d584120-a929-4e7c-9ec2-9998ac639bea/mouse-scroll-in-userform-listbox-in-excel-2010?forum=isvvba
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 PtrSafe Function FindWindow Lib "user32" _
Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function GetWindowLong Lib "user32.dll" _
Alias "GetWindowLongA" ( _
ByVal hwnd As Long, _
ByVal nIndex As Long) As Long
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" _
Alias "SetWindowsHookExA" ( _
ByVal idHook As Long, _
ByVal lpfn As LongPtr, _
ByVal hmod As Long, _
ByVal dwThreadId As Long) As Long
Private Declare PtrSafe Function CallNextHookEx Lib "user32" ( _
ByVal hHook As Long, _
ByVal nCode As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" ( _
ByVal hHook As Long) As Long
Private Declare PtrSafe 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 PtrSafe Function WindowFromPoint Lib "user32" ( _
ByVal xPoint As Long, _
ByVal yPoint As Long) As Long
Private Declare PtrSafe 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 Const cSCROLLCHANGE As Long = 10
Private mLngMouseHook As Long
Private mFormHwnd As Long
Private mbHook As Boolean
Dim mForm As Object
Sub HookFormScroll(oForm As Object)
Dim lngAppInst As Long
Dim hwndUnderCursor As Long
Set mForm = oForm
hwndUnderCursor = FindWindow("ThunderDFrame", oForm.Caption)
Debug.Print "Form window: " & hwndUnderCursor
If mFormHwnd <> hwndUnderCursor Then
UnhookFormScroll
Debug.Print "Unhook old proc"
mFormHwnd = hwndUnderCursor
lngAppInst = GetWindowLong(mFormHwnd, GWL_HINSTANCE)
If Not mbHook Then
mLngMouseHook = SetWindowsHookEx( _
WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0)
mbHook = mLngMouseHook <> 0
If mbHook Then Debug.Print "Form hooked"
End If
End If
End Sub
Sub UnhookFormScroll()
If mbHook Then
UnhookWindowsHookEx mLngMouseHook
mLngMouseHook = 0
mFormHwnd = 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
Debug.Print "action"
Debug.Print "right window"
If wParam = WM_MOUSEWHEEL Then
Debug.Print "mouse scroll"
MouseProc = True
If lParam.hwnd > 0 Then
mForm.ScrollTop = Application.Max(0, mForm.ScrollTop - cSCROLLCHANGE)
Else
mForm.ScrollTop = Application.Min(mForm.ScrollHeight - mForm.InsideHeight, mForm.ScrollTop + cSCROLLCHANGE)
End If
Exit Function
End If
End If
MouseProc = CallNextHookEx( _
mLngMouseHook, nCode, wParam, ByVal lParam)
Exit Function
errH:
UnhookFormScroll
End Function
VBA 用户窗体(旧 Thunderframe)的 Window 不处理任何鼠标消息。您可以使用 Spy++ 快速测试它。不过鼠标是可以挂的
虽然@RicardoDiaz 提供了一个示例,但我应该提到他的钩子是全局的,这意味着您正在跨所有进程的所有线程跟踪鼠标消息。真的很慢而且看起来不流畅。相反,您可以使用本地挂钩(仅限本地线程)。
您可以使用我的存储库 VBA UserForm MouseScroll 中的代码,它适用于 x32 和 x64 版本。它还会滚动表单、框架、组合框、列表框等。也支持水平滚动和缩放。享受吧!
问题出在Excel,必须关闭Visual Basic编辑器!!! Excel->错误!!!
调用的正确代码
模块 1:
Option Explicit
Public Sub ShowModal()
UserForm1.Show vbModal
End Sub
Public Sub ShowModeless()
UserForm1.Show vbModeless
End Sub
模块 2:
Option Explicit
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 WHEEL_DOWN As LongPtr = 7864320
Private Const WHEEL_UP As LongPtr = 4287102976#
Private 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
Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal nCode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As LongPtr
Private Declare PtrSafe Function GetCursorPos Lib "user32" (ByRef lpPoint As POINTAPI) As LongPtr
Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As LongLong) As LongPtr '
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
Private Type POINTAPI
XY As LongLong
End Type
Private Type MOUSEHOOKSTRUCT
pt As POINTAPI
hwnd As LongPtr
wHitTestCode As Long '????
dwExtraInfo As LongPtr
End Type
Private HookPtr As LongPtr, EventControl As Object, EventPtr As LongPtr
'------------------
'Hook, Proc, UnHook
'------------------
Public Sub HookControl(NewEventControl As Object)
If HookPtr = 0 Then
Set EventControl = NewEventControl
EventControl.BackColor = vbRed 'Test
EventPtr = CurserPtr
HookPtr = SetWindowsHookEx(WH_MOUSE_LL, AddressOf MouseProc, FormPtr, 0)
End If
End Sub
Private Function MouseProc(ByVal nCode As Long, ByVal wParam As LongPtr, ByRef lParam As MOUSEHOOKSTRUCT) As LongPtr
On Error GoTo 1
MouseProc = CallNextHookEx(HookPtr, nCode, wParam, ByVal lParam)
Dim WheelScrool As Variant
Select Case True
Case EventControl Is Nothing: UnHookControl
Case EventPtr <> CurserPtr: UnHookControl
Case HookPtr = 0
Case nCode <> HC_ACTION
Case wParam <> WM_MOUSEWHEEL
Case lParam.hwnd = WHEEL_DOWN: WheelScrool = EventControl.ListIndex - 1
Case lParam.hwnd = WHEEL_UP: WheelScrool = EventControl.ListIndex + 1
End Select
If Not IsEmpty(WheelScrool) Then
WheelScrool = IIf(WheelScrool < 0, 0, WheelScrool)
WheelScrool = IIf(WheelScrool > EventControl.ListCount - 1, EventControl.ListCount - 1, WheelScrool)
If EventControl.BackColor <> vbYellow Then EventControl.BackColor = vbYellow 'Test
EventControl.ListIndex = WheelScrool
End If
Exit Function
1: UnHookControl
End Function
Public Sub UnHookControl()
If HookPtr <> 0 Then
UnhookWindowsHookEx HookPtr
HookPtr = 0
EventControl.BackColor = vbGreen 'Test
Set EventControl = Nothing
End If
End Sub
'---------------------------
'Status query (not required)
'---------------------------
Public Property Get IsHookControl() As Boolean
IsHookControl = (HookPtr <> 0)
End Property
'------------------
'Pointer Functionen
'------------------
Public Function CurserPtr() As LongPtr
Dim tPT As POINTAPI: GetCursorPos tPT
CurserPtr = WindowFromPoint(tPT.XY)
End Function
Private Function FormPtr() As LongPtr
Dim fHw As LongPtr: fHw = FindWindow("ThunderDFrame", EventControl.Parent.Caption)
FormPtr = GetWindowLong(fHw, GWL_HINSTANCE)
End Function
用户表单:
'-----------------------------
'Elemente:
' ComboBox1
' ListBox1
' ListBox2
'-----------------------------
Option Explicit
Private ActControl As Object
'---------
'User Form
'---------
Private Sub UserForm_Initialize()
Dim i As Long
For i = 10 To 30
ListBox1.AddItem i & " - ListBox1"
ListBox2.AddItem i & " - ListBox2"
ComboBox1.AddItem i & " - ComboBox1"
Next
ComboBox1.ListIndex = 0
End Sub
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
UnHookControl
End Sub
'----------------------------
'CombBox1, ListBox1, ListBox2
'----------------------------
Private Sub ComboBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
HookControl ComboBox1
End Sub
Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
HookControl ListBox1
End Sub
Private Sub ListBox2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
HookControl ListBox2
End Sub