I used code that was supplied by Cory from this thread mouse-wheel-scroll-userform. I adapted it for 64 bit use. It partially works. It will scroll up but not down and it scrolls up for both up and down wheel movement. Here is the code.
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
' https://www.ozgrid.com/forum/index.php?thread/128354-mouse-wheel-scroll-userform/
' Defince constants
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
' Define types for API calls
Private Type POINTAPI
x As Long
y As Long
End Type
#If Win64 Then
Type MOUSEHOOKSTRUCT
pt As POINTAPI
hwnd As LongPtr
wHitTestCode As Long
dwExtraInfo As LongPtr
End Type
#Else
Private Type MOUSEHOOKSTRUCT
pt As POINTAPI
hwnd As Long
wHitTestCode As Long
dwExtraInfo As Long
End Type
#End If
' Delclare API functions
#If Win64 Then
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" ( _
ByVal hwnd As LongPtr, _
ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" ( _
ByVal idHook As Long, _
ByVal lpfn As LongPtr, _
ByVal hmod As LongPtr, _
ByVal dwThreadId As Long) As LongPtr
Private Declare PtrSafe Function CallNextHookEx Lib "user32" ( _
ByVal hHook As LongPtr, _
ByVal ncode As Long, _
ByVal wParam As LongPtr, _
lParam As Any) As LongPtr
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" ( _
ByVal hhk As LongPtr) As Long
Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" ( _
ByVal hwnd As LongPtr, _
ByVal wMsg As Long, _
ByVal wParam As LongPtr, _
ByVal lParam As LongPtr) As Long
Private Declare PtrSafe Function WindowFromPoint Lib "user32" ( _
ByVal Point As LongLong) As LongPtr
Private Declare PtrSafe Function GetCursorPos Lib "user32" ( _
lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
#Else
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
#End If
' Define variables
#If Win64 Then
Private mFormHwnd As LongPtr
Private mLngMouseHook As LongPtr
#Else
Private mFormHwnd As Long
Private mLngMouseHook As Long
#End If
Private mbHook As Boolean
Dim mForm As ObjectCode
Sub HookFormScroll(oForm As Object)
#If Win64 Then
Dim hwndUnderCursor As LongPtr
Dim lngAppInst As LongPtr
#Else
Dim hwndUnderCursor As Long
Dim lngAppInst As Long
#End If
Set mForm = oForm
hwndUnderCursor = FindWindow("ThunderDFrame", oForm.Caption)
Debug.Print "Form window: " & hwndUnderCursor
If mFormHwnd <> hwndUnderCursor Then
UnhookFormScroll
Debug.Print "Unhook old proc"
mFormHwnd = hwndUnderCursor
lngAppInst = GetWindowLong(mFormHwnd, 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 SubCode
#If Win64 Then
Private Function MouseProc(ByVal ncode As Long, ByVal wParam As Long, ByRef lParam As MOUSEHOOKSTRUCT) As LongPtr
#Else
Private Function MouseProc(ByVal ncode As Long, ByVal wParam As Long, ByRef lParam As MOUSEHOOKSTRUCT) As Long
#End If
On Error GoTo errH 'Resume Next
If (ncode = HC_ACTION) Then
If GetActiveWindow = mFormHwnd Then
If wParam = WM_MOUSEWHEEL Then
MouseProc = True
'Debug.Print lParam.hwnd
If lParam.hwnd > 0 Then
mForm.ScrollTop = Application.Max(0&, mForm.ScrollTop - cSCROLLCHANGE)
Else
mForm.ScrollTop = Application.Min(mForm.ScrollHeight - mForm.InsideHeight, mForm.ScrollTop + cSCROLLCHANGE)
End If
Exit Function
End If
End If
End If
MouseProc = CallNextHookEx(mLngMouseHook, ncode, wParam, ByVal lParam)
Exit Function
errH:
UnhookFormScroll
End FunctionCode
Sub UnhookFormScroll()
If mbHook Then
UnhookWindowsHookEx mLngMouseHook
mLngMouseHook = 0
mFormHwnd = 0
mbHook = False
End If
End SubAnyone see what is wrong?
Thanks