Implement Mousewheel in msforms.textbox - vba

Question

I’m trying to implement mousewheel scroll in a large text box. I found Peter Thornton’s code and it works well for frames and userforms (only using it for the former right now), but not for text box because text boxes don’t have a .ScrollTop property.
The code I use now isn’t actually a scroll-wheel function. Full code below, but the relevant portion is:
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
Can anybody give any suggestions on how I could implement actual scroll wheel functionality? One idea I have is to find:
Whether the scroll bar was active (the content isn't always long enough to activate it - but don't know how, windows API?).
Storing .SelStart in a temporary variable
Find the top / bottom line somehow (I can't find any property of the textbox like this in documentation)
Increase the bottom line / decrease the top line (as appropriate) by setting .CurLine
Resetting .SelStart to the temporary variable (or top / bottom line, if the line stored in the temporary variable is no longer visible).
This isn't ideal either, however, because it doesn't preserve the previous cursor position if you scroll too far. I might be able to work around it by storing the .SelStart variable in the module's state and jumping back to it on the KeyDown event. There are some really big gaps, however, that I don't really have a good idea of how to fill. Any ideas (for this or other, more elegant solutions)? Thank you in advance.
Full code:
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 worked fine for me. It's one module and a few lines of code to put on your form.