Option Compare Database
Option Explicit
' *****************************************************************************
' * ------------ MOUSE HOOK for Microsoft(r) Access VBA ------------ *
' * ------------ (c) Wayne Phillips / iTech Masters 2009 ------------ *
' * ------------ http://www.everythingaccess.com ------------ *
' *****************************************************************************
' * *
' * This module exposes a function that creates an in-memory, COM-compatible *
' * object that is written in native x86 code rather than VBA. *
' * *
' * The purpose of this module is to allow easy disabling of the mouse scroll *
' * wheel in Forms, without needing a DLL and without VBA problems usually *
' * associated with subclassing windows: *
' * http://support.microsoft.com/?kbid=278379 *
' * *
' * - v1.2 28/08/2009 - now compatible with both VBA5 and VBA6 (Access 97+) *
' * - v1.4 01/09/2009 - Scroll disabled by default, for convenience *
' * - v1.5 04/12/2009 - now the methods Init and Scroll are case insensitive *
' * *
' * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*
' * All the benefits of using a native compiled DLL - without needing a DLL! *
' * *
' * You are free to include this module in your project provided that you *
' * leave this copyright notice in place and that no modifications are made. *
' * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*
' * Instructions: *
' * *
' * Add the following code to your OnOpen event: *
' * *
' * Private Sub Form_Open(Cancel As Integer) *
' * Static MouseHook As Object *
' * Set MouseHook = NewMouseHook(Me) *
' * End Sub *
' * *
' *****************************************************************************
Private Declare Function VirtualAlloc Lib "kernel32" (ByVal Address As Long, ByVal Size As Long, ByVal AllocationType As Long, ByVal Protect As Long) As Long
Private Declare Function GetModuleHandleA Lib "kernel32" (ByVal ProcName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal Module As Long, ByVal ProcName As String) As Long
Private Declare Sub CopyMemoryAnsi Lib "kernel32" Alias "RtlMoveMemory" (ByVal Dest As Long, ByVal Source As String, ByVal Size As Long)
Private Declare Sub CastToObject Lib "kernel32" Alias "RtlMoveMemory" (ByRef Dest As Object, ByRef Source As Long, ByVal Size As Long)
Private Const SIZEOF_PTR32 As Long = &H4
Private Const PAGE_EXECUTE_RW As Long = &H40
Private Const MEM_RESERVE_AND_COMMIT As Long = &H3000
Private Const ERR_OUT_OF_MEMORY As Long = &H7
Private Type IDispatchVTable
QueryInterface As Long
AddRef As Long
Release As Long
GetTypeInfoCount As Long
GetTypeInfo As Long
GetIDsOfNames As Long
Invoke As Long
End Type
Public Function NewMouseHook(ByRef Form As Access.Form) As Object
Dim NativeCode As String
Dim Kernel32Handle As Long
Dim GetProcAddressPtr As Long
Dim MouseHookAddr As Long
Dim MouseHookLoader As Object
Dim LoaderVTable As IDispatchVTable
NativeCode = "123"
' Allocate the executable memory for the object
MouseHookAddr = VirtualAlloc(0, Len(NativeCode), MEM_RESERVE_AND_COMMIT, PAGE_EXECUTE_RW)
If MouseHookAddr <> 0 Then
' Copy the x86 native code into the allocated memory
Call CopyMemoryAnsi(MouseHookAddr, NativeCode, Len(NativeCode))
' Force the memory address into an Object variable (also triggers the shell code)
LoaderVTable.QueryInterface = MouseHookAddr
Call CastToObject(MouseHookLoader, VarPtr(VarPtr(LoaderVTable)), SIZEOF_PTR32)
If Not TypeOf MouseHookLoader Is VBA.Collection Then
Set NewMouseHook = (MouseHookLoader)
Set MouseHookLoader = Nothing
End If
' Initialize our COM object
Kernel32Handle = GetModuleHandleA("kernel32")
GetProcAddressPtr = GetProcAddress(Kernel32Handle, "GetProcAddress")
Call NewMouseHook.Init(Kernel32Handle, GetProcAddressPtr, Form.hwnd)
' Disable the scroll wheel by default.
NewMouseHook.Scroll = False
Else
Err.Raise ERR_OUT_OF_MEMORY
End If
End Function
