vba - 在 msforms.textbox 中实现鼠标滚轮

Question

我正在尝试在大文本框中实现鼠标滚轮滚动。我找到了 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

任何人都可以就如何实现实际的滚轮功能提出任何建议吗？我的一个想法是找到:

1. 滚动条是否处于事件状态(内容并不总是足够长以激活它 - 但不知道如何激活，Windows API？)。
2. 将 .SelStart 存储在一个临时变量中
3. 以某种方式找到顶部/底部线(我在文档中找不到像这样的文本框的任何属性)
4. 通过设置 .CurLine 增加底线/减少顶线(视情况而定)
5. 将 .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

Answer 1

Daniel Pineault's code对我来说很好。只需一个模块和几行代码即可添加到您的表单中。