Mikeymike_W
Board Regular
- Joined
- Feb 25, 2016
- Messages
- 171
Hi,
This code allows me to use the scroll wheel on my userforms.
I've been using this bit of code successfully but now i have a 64 bit system and its throwing up the following error:
Compile error:
The code in this project must be updated for use on 64-bit systems.
Please review and update Declare statements and then mark them with the PtrSafe attribute.
I'm not entirely literate in vba. I assume i need to change "user32" to "user64"?
I know i also need to put in "ptrsafe" in some locations but i'm not sure where. From research i also saw that some declarations need to be changed "Long" to "LongPtr"... its a minefield and i've no idea how to change it so it keeps working on 32 and 64 bit system.
I hope that someone can help!
This code allows me to use the scroll wheel on my userforms.
I've been using this bit of code successfully but now i have a 64 bit system and its throwing up the following error:
Compile error:
The code in this project must be updated for use on 64-bit systems.
Please review and update Declare statements and then mark them with the PtrSafe attribute.
I'm not entirely literate in vba. I assume i need to change "user32" to "user64"?
I know i also need to put in "ptrsafe" in some locations but i'm not sure where. From research i also saw that some declarations need to be changed "Long" to "LongPtr"... its a minefield and i've no idea how to change it so it keeps working on 32 and 64 bit system.
I hope that someone can help!
VBA 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
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 = 40
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)
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 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 'Resume Next
If (nCode = HC_ACTION) Then
Debug.Print "action"
Debug.Print "right window"
If wParam = WM_MOUSEWHEEL Then
Debug.Print "mouse scroll"
MouseProc = True
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
MouseProc = CallNextHookEx( _
mLngMouseHook, nCode, wParam, ByVal lParam)
Exit Function
errH:
UnhookFormScroll
End Function
