Hook Mouse wheel to scroll Userform Frame
Found this to be a handy addition to allow scrolling in userform frames or other controls
module code
Code
- Option Explicit
- 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
- 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 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)
- If mFormHwnd <> hwndUnderCursor Then
- UnhookFormScroll
- mFormHwnd = hwndUnderCursor
- lngAppInst = GetWindowLong(mFormHwnd, GWL_HINSTANCE)
- If Not mbHook Then
- mLngMouseHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0)
- mbHook = mLngMouseHook <> 0
- 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
- If (nCode = HC_ACTION) Then
- If GetActiveWindow = mFormHwnd Then
- If wParam = WM_MOUSEWHEEL Then
- MouseProc = True
- If lParam.hwnd > 0 Then
- mForm.ScrollBar1.Value = Application.Min(0, mForm.ScrollBar1.Value + cSCROLLCHANGE)
- Else
- mForm.ScrollBar1.Value = Application.Max(-250, mForm.ScrollBar1.Value - cSCROLLCHANGE)
- End If
- Exit Function
- End If
- End If
- End If
- MouseProc = CallNextHookEx(mLngMouseHook, nCode, wParam, ByVal lParam)
- Exit Function
- errH:
- UnhookFormScroll
- End Function
Userform code
Code
- Private Sub CommandButton1_Click()
- If Me.OptionButton2.Value = True Then
- ActiveWorkbook.Close
- ActiveWorkbook.Saved = True
- ElseIf Me.OptionButton1.Value = True Then
- UnhookFormScroll
- Unload Me
- Else
- MsgBox " you must read the agreement prior to commencing something"
- End If
- End Sub
- Private Sub ScrollBar1_Change()
- ProNotes.Frame1.Top = ProNotes.ScrollBar1.Value
- End Sub
- Private Sub UserForm_Activate()
- HookFormScroll Me
- End Sub
- Private Sub UserForm_Deactivate()
- UnhookFormScroll
- End Sub
- Private Sub UserForm_Initialize()
- HookFormScroll Me
- End Sub
- Private Sub UserForm_QueryClose(Cancel%, CloseMode%)
- Dim uname$
- If CloseMode = vbFormControlMenu Then
- MsgBox " click the OK button to close the UserForm.", , "Dude"
- Cancel = True
- End If
- End Sub