我想在一个大型文本框中实现鼠标滚轮滚动。我找到了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