我正在尝试在大文本框中实现鼠标滚轮滚动。我找到了 Peter Thornton 的代码，它适用于框架和用户窗体(目前仅将其用于前者)，但不适用于文本框，因为文本框没有 .ScrollTop 属性。
我现在使用的代码实际上并不是滚轮功能。完整代码如下，但相关部分是:
If TypeName(mControl) = "TextBox" Then
If reasonCustKeyPressed Then
lngSelStart = .SelStart
.CurLine = .CurLine
lngOldLinePos = lngSelStart - .SelStart
reasonCustKeyPressed = False
End If
If lParam.Hwnd > 0 Then
.CurLine = Application.Max(0, .CurLine - cTBOX_SCROLLCHANGE)
Else
.CurLine = Application.Min(.LineCount - 1, .CurLine + cTBOX_SCROLLCHANGE)
End If
lngSelStart = .SelStart
If .CurLine < .LineCount - 1 Then
.CurLine = .CurLine + 1
.SelStart = .SelStart - 1
Else
.SelStart = Len(.Text)
End If
lngNewLineLen = .SelStart - lngSelStart
.SelStart = Application.Min(lngSelStart + lngOldLinePos, lngSelStart + lngNewLineLen)
End If
任何人都可以就如何实现实际的滚轮功能提出任何建议吗？我的一个想法是找到:
- 滚动条是否处于事件状态(内容并不总是足够长以激活它 - 但不知道如何激活，Windows API？)。
- 将
.SelStart存储在一个临时变量中 - 以某种方式找到顶部/底部线(我在文档中找不到像这样的文本框的任何属性)
- 通过设置
.CurLine增加底线/减少顶线(视情况而定) - 将
.SelStart重置为临时变量(或顶行/底行，如果存储在临时变量中的行不再可见)。
然而，这也不理想，因为如果滚动太远，它不会保留先前的光标位置。我可以通过将 .SelStart 变量存储在模块的状态中并在 KeyDown 事件中跳回到它来解决这个问题。然而，有一些非常大的差距，我真的不知道如何填补。任何想法(对于这个或其他更优雅的解决方案)？先感谢您。
完整代码:
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
Declare Function GetActiveWindow Lib "user32" () 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 cFRAME_SCROLLCHANGE As Long = 20
Private Const cTBOX_SCROLLCHANGE As Long = 1
Private mLngMouseHook As Long
Private mControlHwnd As Long
Private mbHook As Boolean
Private lngOldLinePos As Long
Dim mControl As Object
Sub HookFormScroll(oControl As Object, strFormCapt As String)
Dim lngAppInst As Long
Dim hwndUnderCursor As Long
Set mControl = oControl
hwndUnderCursor = FindWindow("ThunderDFrame", strFormCapt)
Debug.Print "Form window: " & hwndUnderCursor
If mControlHwnd <> hwndUnderCursor Then
UnhookFormScroll
Debug.Print "Unhook old proc"
mControlHwnd = hwndUnderCursor
lngAppInst = GetWindowLong(mControlHwnd, 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
mControlHwnd = 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 lngSelStart As Long, lngNewLineLen As Long
On Error GoTo errH 'Resume Next
If (nCode = HC_ACTION) Then
If GetActiveWindow = mControlHwnd Then
If wParam = WM_MOUSEWHEEL Then
mouseProc = True
With mControl
If TypeName(mControl) = "Frame" Then
If lParam.Hwnd > 0 Then
.ScrollTop = Application.Max(0, .ScrollTop - cFRAME_SCROLLCHANGE)
Else
.ScrollTop = Application.Min(.ScrollHeight - .InsideHeight, .ScrollTop + cFRAME_SCROLLCHANGE)
End If
Else
If TypeName(mControl) = "TextBox" Then
If reasonCustKeyPressed Then
lngSelStart = .SelStart
.CurLine = .CurLine
lngOldLinePos = lngSelStart - .SelStart
reasonCustKeyPressed = False
End If
If lParam.Hwnd > 0 Then
.CurLine = Application.Max(0, .CurLine - cTBOX_SCROLLCHANGE)
Else
.CurLine = Application.Min(.LineCount - 1, .CurLine + cTBOX_SCROLLCHANGE)
End If
lngSelStart = .SelStart
If .CurLine < .LineCount - 1 Then
.CurLine = .CurLine + 1
.SelStart = .SelStart - 1
Else
.SelStart = Len(.Text)
End If
lngNewLineLen = .SelStart - lngSelStart
.SelStart = Application.Min(lngSelStart + lngOldLinePos, lngSelStart + lngNewLineLen)
End If
End If
End With
Exit Function
End If
End If
End If
mouseProc = CallNextHookEx( _
mLngMouseHook, nCode, wParam, ByVal lParam)
Exit Function
errH:
UnhookFormScroll
End Function
最佳答案
Daniel Pineault's code对我来说很好。只需一个模块和几行代码即可添加到您的表单中。
关于vba - 在 msforms.textbox 中实现鼠标滚轮，我们在Stack Overflow上找到一个类似的问题： https://stackoverflow.com/questions/53571453/