469,167 Members | 2,044 Online
Bytes | Developer Community
New Post

Home Posts Topics Members FAQ

Post your question to a community of 469,167 developers. It's quick & easy.

Disable Mousewheel without using MouseWheel.dll file

How to disable Mousewhell without using MouseWheel.dll file and copy it to each computer need to prevent scrolling.
If there are many computer use the program, I can't setup one bye one.
So, please support me!
Thanks
Sep 20 '10 #1

✓ answered by munkee

Here you go mate a script I found weeks ago which works very good:

Place this inside a module:

Expand|Select|Wrap|Line Numbers
  1. Option Explicit
  2.  
  3. '   *****************************************************************************
  4. '   * ------------      MOUSE HOOK for Microsoft(r) Access VBA     ------------ *
  5. '   * ------------      (c) Wayne Phillips / iTech Masters 2009    ------------ *
  6. '   * ------------          http://www.everythingaccess.com        ------------ *
  7. '   *****************************************************************************
  8. '   *                                                                           *
  9. '   * This module exposes a function that creates an in-memory, COM-compatible  *
  10. '   * object that is written in native x86 code rather than VBA.                *
  11. '   *                                                                           *
  12. '   * The purpose of this module is to allow easy disabling of the mouse scroll *
  13. '   * wheel in Forms, without needing a DLL and without VBA problems usually    *
  14. '   * associated with subclassing windows:                                      *
  15. '   * http://support.microsoft.com/?kbid=278379                                 *
  16. '   *                                                                           *
  17. '   * - v1.2 28/08/2009 - now compatible with both VBA5 and VBA6 (Access 97+)   *
  18. '   * - v1.4 01/09/2009 - Scroll disabled by default, for convenience           *
  19. '   * - v1.5 04/12/2009 - now the methods Init and Scroll are case insensitive  *
  20. '   *                                                                           *
  21. '   * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*
  22. '   * All the benefits of using a native compiled DLL - without needing a DLL!  *
  23. '   *                                                                           *
  24. '   *   You are free to include this module in your project provided that you   *
  25. '   *  leave this copyright notice in place and that no modifications are made. *
  26. '   * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*
  27. '   * Instructions:                                                             *
  28. '   *                                                                           *
  29. '   *  Add the following code to your OnOpen event:                             *
  30. '   *                                                                           *
  31. '   *     Private Sub Form_Open(Cancel As Integer)                              *
  32. '   *         Static MouseHook As Object                                        *
  33. '   *         Set MouseHook = NewMouseHook(Me)                                  *
  34. '   *     End Sub                                                               *
  35. '   *                                                                           *
  36. '   *****************************************************************************
  37.  
  38. Private Declare Function VirtualAlloc Lib "kernel32" (ByVal Address As Long, ByVal Size As Long, ByVal AllocationType As Long, ByVal Protect As Long) As Long
  39. Private Declare Function GetModuleHandleA Lib "kernel32" (ByVal ProcName As String) As Long
  40. Private Declare Function GetProcAddress Lib "kernel32" (ByVal Module As Long, ByVal ProcName As String) As Long
  41. Private Declare Sub CopyMemoryAnsi Lib "kernel32" Alias "RtlMoveMemory" (ByVal Dest As Long, ByVal Source As String, ByVal Size As Long)
  42. Private Declare Sub CastToObject Lib "kernel32" Alias "RtlMoveMemory" (ByRef Dest As Object, ByRef Source As Long, ByVal Size As Long)
  43.  
  44. Private Const SIZEOF_PTR32              As Long = &H4
  45. Private Const PAGE_EXECUTE_RW           As Long = &H40
  46. Private Const MEM_RESERVE_AND_COMMIT    As Long = &H3000
  47. Private Const ERR_OUT_OF_MEMORY         As Long = &H7
  48.  
  49. Private Type IDispatchVTable
  50.     QueryInterface As Long
  51.     AddRef As Long
  52.     Release As Long
  53.     GetTypeInfoCount As Long
  54.     GetTypeInfo As Long
  55.     GetIDsOfNames As Long
  56.     Invoke As Long
  57. End Type
  58.  
  59. Public Function NewMouseHook(ByRef Form As Access.Form) As Object
  60.  
  61.     Dim NativeCode As String
  62.     Dim Kernel32Handle As Long
  63.     Dim GetProcAddressPtr As Long
  64.     Dim MouseHookAddr As Long
  65.     Dim MouseHookLoader As Object
  66.     Dim LoaderVTable As IDispatchVTable
  67.  
  68.     NativeCode = _
  69.             "XYQPSWQ[T_S\\[S\XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX- %uUPXX-īT[PXX-E%%ePXX-uu0E-uu0EPXX-eeE%PXX-%e%uPXX-eeE PXX-%eE PXXX@@fX<0tF4+&4+2'&,V/PCp@-''2V/5+1''3V/ys 1S CCCuRfI>_ltcDPC@KCQcBnIAGBqcDPO@GBE@KCqc@YMQHUqp@dQ^AAAAGBUBISExD]MQQ=OYHAQ@\EAA@eiQDeiQHMIqFeiQLMIqHeiQPMIqHeiQTMIqHeiQXucOAAAAMcY^AAAAIsEHDEQCAeE@AeEC?GGCPCXM@BeqDAAoAAEA@KMC@azC@IAaBB@Ax[AABAiqXAqa<QCC@UFLwREHTIAA@AA\jmIPdqpaxBA\\mITdQqcRmiEMKX^AAAAf\MAIAQcP  TKKp>RPQM@JMH@azA@IAaBRCAHAAA@qjE@AA>JAAAxnAA@qCB@AADMAAAtuAA@QTB@AAlNAAAhAAA@UtclNIpt^]P<[VPXKpcEp>bPpQcU ?bM ? ypCAuPqM@n_LKWDBCkoAtTPajbaA@AQ\MmYRxBY_tAQ\DMBqkbp>uPp>u@p>upq>u pcU ??rpscM ??QPucevdqPAAePWtclNIppbG<AAAAhB L@AQWIWE>sA]cE ?bU ?bMpnpDEpU?WE?KWE?KWD>FRaAU<_PxnYRxnYP<[M@Hmy>E ?bU ?bMpnpDE@z?WE?KWE?KWD>FRaAS<_PxnYRxnYP<[M@HMy>E ?bU ?bMpnpDEP^?WE?KWE?KWD>FRaAT=_PxnYRxnYP<[M@HAq>E ?bU ?bMpnpDEP\?WE?KWE?KWD>FRaAK=_PxnYRxnYP<[M@Haz>E ?bU ?bMpnpDE @?WE?KWE?KWD>FRaA@<_PxnYRxnYP<[M@HAq>E ?bU ?bMpnpDE@a?WE?KWE?KWD>FRaAY<_PxnYRxnYP<[M@Hut>E ?b" & _
  70.             "U ?bMpnpDEpW?WE?KWE?KWD>FRaAB>_PxnYRxnYP<[M@Hqq>E ?bU ?bMpnpDE@A?WE?KWE?KWD>FRaAK?_PxnYRxnYP<[M@HUt>E ?bU ?bMpnpDE@B?WE?KWE?KWD>FRaAC?_PxnYRxnYP<[M@HI=?E ?bU ?bMpnpDE@@?WE?KWE?KWD>FRaAK?_PxnYRxnYP<[M@HIp>E ?bU ?bMpnpDEPc?WE?KWE?KWD>FRaAU<_PxnYRxnYP<[M@Hq>?E ?bU ?bMpnpDEpa?WE?KWE?KWD>FRaAz<_PxnYRxnYP<[M@HQq>E ?bU ?bMpnpDE@A?WE?KWE?KWD>FRaAu<_PxnYRxnYP<[M@Hip>E ?bU ?bMpnpDEPo?WE?KWE?KWD>FRaAC=_PxnYRxnYP<[M@HAq>E ?bU ?bMpnpDE@A?WE?KWE?KWD>FRaA@=_PxnYRxnYP<[M@Hmy>E ?bU ?bMpnpDEPP?WE?KWE?KWD>FRaAL=_PxnYRxnYP<[M@Hey>E ?bU ?bMpnpDEpq?WE?KWE?KWD>FRaAC?_PxnYRxnYP<[M@HA=?E ?bU ?bMpnpDE@B?WE?KWE?KWD>FRaAy=_PxnYRxnYP<[M@Hiu>E ?bU ?bMpnpDE@C?WE?KWE?KWD>FRaAt<_PxnYRxnYP<[M@Haq>E ?bU ?bMpnpDEPA?WE?KWE?KWD>FRaAX=_PxnYRxnYP<[M@HMy>E ?bU ?bMpnpDE@q?WE?KWE?KWD>FRaAD=_PxnYRxnYP<[M@HEu>E ?bU ?bMpnpDEp;?WE?KWE?KWD>FRaAs>_PxnYRxnYP<[M@HMy>E ?bU ?bMpnpDE ^?WE?KWE?KWD>FRaAD=_PxnYRxnYP<[M@HAq>E ?bU ?bMpnpDEP\?WE?KWE?KWD>FRaAF=_PxnYRxnYP<[M@Hmy>E ?bU ?bMpnpDEPR?WE?KWE?KWD>FRaAL=_PxnYRxnYP<[M@" & _
  71.             "Hey>E ?bU ?bMpnpDE R?WE?KWE?KWD>FRaAD=_PxNRsIwE<ifL@@Aq[EPNFACMNs^EAIWE=KWD?KwE>FRQEK?_PxnYPxnYT<[M@Buu>E ?bM ?bEpnpDaAE?WE?KWD?KwE>FRQEA?_PxnYPxnYT<[M@Bev>E ?bM ?bEpnpDaAA?WE?KWD=JkAaa>?bE ?bUpNcLIq>E ?bM@>bAEM;HQs>KWD?KwE>HSQE?WE?KWE=KCPqjB@ab>?bM ?bEpNcTaq>E ?bU@>bJE];XAYy?oYPxnYT<cIBB=_PxnYRxnYP<[M@HUv>E ?bU ?bMpnpDEpN?WE?KWE?KWD>FRaAA?_PxnYRxnYP<[M@Hev>E ?bU ?bMpnpDE@@?WE?KWE=JCD@@K??KwE?KWE>HS@C?WE?KWD=KkE@AfOC@G??KWE?KWD>HsaA?WE?KwE=KGE@AbOEd=?bU ?bMpNcDEp>E ?bE@>bPPQqjb@ab>?bM ?bEpNcTaq>E ?bU ?bMpnpDEP\?WE?KWE?KWD>FRaAv=_PxnYRxnYP<[M@HEy>E ?bU ?bMpnpDEP_?WE?KWE?KWD>FRaAH=_PxnYRpjYQHQs>KWD?KwE>HSQE?WE?KWE=KCDCAjOC@K??KwE?KWE>HS@C?WE?KWD=KkECAfOE@G??KWE?KWD>HsaA?WE?KwE=KGECAbOGd=?bU ?bMpNcDEp>E ?bE ?bUpnpDIQ\?WE?KwE?KWE>FRACm=_PxnYTxnYR<[M@QEy>E ?bE ?bUpnpDIQ_?WE?KwE?KWE>FRACL=_PxnYTpjiSLAYy?oYPxnYT<cIBB=_PxnYRpnYQLEM;HQs>KWD?KwE>HSQE?WE?KWE=KCDBAjOE@K??KwE?KWE>HS@C?WE?KWD=KkEBAfOG@G??KWE?KWD>HsaA?WE?KwE?KWE>FRACu<_PxnYTxnYR<[M@QQs>E ?bE ?bUpnpDIqc?WE?KwE?KWE>" & _
  72.             "FRACE<_PxnYTxnYR<[M@Qq>?E ?bE ?bUpnpDIqc?WE?KwE?KWE>FRACP<_PxnYTxnYR<[M@QQq>E ?bE ?bUpnpDIQa?WE?KwE?KWE>FRACB>_PxnYTtnisAJ?@kElcDUHRs^EAABoAd=?bU ?bMpNcDEp>E ?bEP>bPFMyCmcqKsQ LL>Q@E]yBE]?HAYy?oYPxnYT<cIBB=_PxnYRtnYqAF?@ka=bTuIRs^EAAJoAAjNE@K??KwE?KWE>HS@C?WE?KWD<Kk]qbNqKQnI@Usu=G@Qq KQqxb@H?oYTxnYR<cI@Q=_PxnYPxnYT<[M@Bmy>E ?bM ?bEpnpDaQR?WE?KWD?KwE>FRQET=_PxnYPxnYT<[M@Bey>E ?bM ?bEpnpDaQE?WE?KWD?KwE>FRQEK?_PxnYPxnYT<[M@BUu>E ?bM ?bEpnpDaAD?WE?KWD?KwE>FRQEK?_PxnYPxnYT<[M@BAp>E ?bM ?bEpnpDaaU?WE?KWD?KwE>FRQEK?_PxnYPxnYT<[M@Biq>E ?bM ?bEpnpDaq>?WE?KWD?KwE>FRQEQ<_PxnYPxnYT<[M@BQq>E ?bM ?bEpnpDaqM?WE?KWD?KwE>FRQE@>_PxnYPxnYT<[M@Bet>E ?bM ?bEpnpDaQV?WE?KWD?KwE>FRQE[<_PxnYPxnYT<[M@BI=?E ?bM ?bEpnpDaAB?WE?KWD?KwE>FRQE@=_Px>_PtnYPtnR@XG?Q@= aXm>??oYTxnYR<[M@Qmy>E ?bE ?bUpnpDIQR?WE?KwE?KWE>FRACT=_PxnYTxnYR<[M@Q]=?E ?bE ?bUpnpDIQA?WE?KwE?KWE>FRAC@=_PxnYTxnYR<[M@QAq>E ?bE ?bUpnpDIAA?WE?KwE?KWE>FRAC@=_PxnYTxnYR<[M@Qaz>E ?bE ?bUpnpDIaA?WE?KwE?KWE>FRAC@<_PxnYTxnYR<[M@QAq>E ?bE ?b" & _
  73.             "UpnpDIAa?WE?KwE?KWE>FRACK?_PxnYTxnYR<[M@QA=?E ?bE ?bUpnpDIqc?WE?KwE?KWE>FRAC@>_PxnYTxnYR<[M@Qet>E ?bE ?bUpnpDIQV?WE?KwE?KWE>FRAC[<_PxnYTxnYR<[M@QI=?E ?bE ?bUpnpDIAB?WE?KwE?KWE>FRAC@=_PxnYTxnYR<[M@QAx>E ?bEp>bevtqUlIzQlYPHMIqDmIEIWD>KwE>CgF@@UVCKWECKWD>IKE@KC=b@nYR<oYA?GQW]HM@@AHePOTTKs?TCwFD@UvCxKAQ@AYW]ldqLAqcUpqaBRqcReYT<Oi_DAQ\ZezA@AAAKWEBIO= @rQOJ @\HEAGCCM@Al?<CkF@@Uf@KwEBIkE@KwEEAgFA@AAA@UvNAgF@@AAA@UfLAgFC@BAA@UVJAgFB@AAAFTFHKWE>KCD@AKMA@AAAKwEDIGpcEPpcPItcJ=_UDMBqYttWBrAAKwEEAgFA@QaA@UvNAgF@@AAA@UfLAgFC@BAA@UVJAgFB@AAAFTFHKWE>KCD@AKMA@AAAKwEDIGpcEPpcPItcJ=_UDMBqYttWBrAAKwEDGFAA@AAAxKAQ@Ayc@nIqYttWBrAAPWtclFtcE pa@RqcPeYT<oYR<OY_DAQ\ImYPHmYT<giQDmIqKC=bMp>bA=_AYtdqDAAePCXTKs? DR>TKWECCCM@KCPcUp>bMp> yPAAudqcE pcUp^cBPqcMp>?ImYP<OIO@=P aCAA@mYT<Oi_LAqBDSHA@AqcMp>bApqaxpCAt rcUp>bJpq>qpc[<oYP<oIUL=o]pmYR<oYQL=OUHlYT<oiSLMBqIGEJKWD>KkEBCgBAtxqcEp>bPpqcJEtcA=OUHmYT<oiSLmYQ@dYPxnYT<oiSDEY;DFAA@eYRtnYP<?O]LmYT<oiSLmYAPlIE?KDDKWE?KwE<Is_V[LIpDaGA@CAAj@QUS<OyKC=b@nYR" & _
  74.             "<oYA[lYx]HM@@AHeUlIzQlYPHMIqDmIEIWD>KC=b@bZA@@AaYtdqHAAePCXTKs_UKWECCCM@KCPcUp>b@nIqxGAQ@AYW]HME@AHePWtclFtcE pa@RqcPeYT<OY^TEA\JaZA@@AainRA@AqcU@pcJYwayeE\KmYPPmIEfLiOiTFXKwEEKGaXCcfANPFBKWDEKkaXCgfAnTFRKWEEKC YCkF@IPFBKwEEKGaXCcF@iTFLKWDEKkaXCgf@TPFBKWEEKC YCkf@tTFFKwEEKGaXCcFC@UFEKWDFGJQA@AAAsA];ABAA@mYTPmiCfLYOSPvBKWEEKC YCkr]OUYe@AAAKwEEKGaXCcfACPFBKWDEKkaXCgfAcTV_KWEEKC YCkF@RPFBKwEEKGaXCcF@rTVYKWDEKkaXCgf@OPFBKWEEKC YCkf@oTVSKwEEKGaXCcFCLPFBKWDEKkaXCgFClTVMKWEEKC YCkfCLPFBKwEEKGaXCcfClTVGKWDEKkaXCgFB@UVBKWEFGBaA@AAAsA=zVmYT\]mA?????cj@@IAakZqc@nIqsA]W]HMG@AXTKs? Db=bE pa@RqcPeYT<OY^LEqBEkiA@AqcMppay pAthAoNAaA@g_uCAAACwFI@QFCKWDIf\mAAAqcMppcAYNQaAE\OmYT\miCKGEKKCPcU ?zKmYR\mYAKCDKIWD?KwEFKGa<@D@Qt<pcUppcJmYQXmIEIWD<knqcMppcAmIUXeYTtnYR<OYqnDt>u ??UP^cE@>bEp> @>GU?WD=IWEzKWD>AK] @AAAR<_TpfYPhnYR<GYqNCAA@Et>up??UP^cEP_bE@OUjDq>UPo[PlYT KtcJ=_ULmYT<giQLmYP<Wag@AAAP<_TpnYR<oYULeiQdmYP<WQi@AAAPlYR<oYQL=O]d=_TtnYT<oiSLeYQDlYP<WQm@AAAPlYT<oiSL=_]d=_TtnYT<oiSLeYQHlYP" & _
  75.             "<oIQLMbuICDKse]cMp<bEppcPeYTXnYRX>plAubA@@AA?E@\ALI;BQFMHPVDCcoBtHu;ZtsA@@AAtHpahzA\AlORKWDwKkECIwEvkFucE =bP pcJeYR\nOLKWEwO=KUHeYT\nOKKwEwKGECO=KEIWDvkjpcM =L@jYQHeYP\n_BKWDwKkECsAmcAeYP\nYT<oiSLmYP\fYQpmYT<oiSLY]QtEqcEp^@@BAA@At>u ??UP>bUp>bJpQcA@ucEp>bPpqcM@_cJmYP<oIULmYRpfiS<lYP<oIULmYRtfiSxmYP<oIULmYRxfiSXmYP<oIULmYRlfiS\mYP<oIULmYRhfiS lYP<oIULmYRHeiShmYPHmIEKkEFIwEtsA]cE@<bUP<@U@\azYVPXKP\MmYRTNQRPnYP<gYAkrq>E@\a=ALs@AAA<e<?uPl[<oYT<oiSL=_]pmYP<oIUL=oUHlYR<oYULeiQlMBqi>UA@AQ;MDAA@MY^LIqBEOUA@AaXCwFGBQfBfLY^XMA\GYwa=aPAuxucMppay @AthAoNAaA@gOKAAAACwFI@QFHKWDIf\mAKAqcMp>bApAaxPBAtTqaJ>?zBMbuKWEIfdIUHmoCx;@ABAY;tBAA@MBqivOA@AaXCwFGD=P UBAA@mYT\Mi_HEA\JajB@IAai>LA@AqMRfYTLnYR\mYAIWEsKWDsO]jCAgnA@@AA?Y@\LLY;BQvOIPFICgOCtdwaiZA\Hlo_Ag?@@@AAt\paibA\aLY;FQVQkZwcE <bP PcUp=z[lYRHnYQHmIEIWDrkzucM <C?FECIWErkJucU <bJ pB?FQcEp=ztmYTHNRsJkECIwErk^scE <bP pMIjiCIwErkbpcE <C?BDCIWDrkrqcM <bA pB?BPcUp= =qMAOUXqCG_AKWE>KCDBHkELsA=zMazA@IAakZqc@nIqsA=bevdqdAAePCHA@AAA@AAA@iAA" & _
  76.             "@AAA@AAAC@qZ@AFAy@a]@eGAg@A[@QFA @qT@EGAy@aZ@UGA @AU@aGAi@AZ@qGAi@A]@MFA @qJ@ACAi@AT@UGAc@A[@ACAM@QY@MFAt@QX@IFAs@AI@IBApAAM@aBA@AAA@]UXttuZdTFZe TYnPGZeDEAOpUPsIBAOpUPATF\sIBAC<vPePVRapGZoLGAULTPRLbM@MUYlpwTixGXo\FUr<vYA@qUePvTixGXo\FRoxwXA@aTiHF\uDGZFHVXe@AA0"
  77.  
  78.     ' Allocate the executable memory for the object
  79.         MouseHookAddr = VirtualAlloc(0, Len(NativeCode), MEM_RESERVE_AND_COMMIT, PAGE_EXECUTE_RW)
  80.  
  81.     If MouseHookAddr <> 0 Then
  82.  
  83.         ' Copy the x86 native code into the allocated memory
  84.             Call CopyMemoryAnsi(MouseHookAddr, NativeCode, Len(NativeCode))
  85.  
  86.         ' Force the memory address into an Object variable (also triggers the shell code)
  87.             LoaderVTable.QueryInterface = MouseHookAddr
  88.             Call CastToObject(MouseHookLoader, VarPtr(VarPtr(LoaderVTable)), SIZEOF_PTR32)
  89.             If Not TypeOf MouseHookLoader Is VBA.Collection Then
  90.                 Set NewMouseHook = (MouseHookLoader)
  91.                 Set MouseHookLoader = Nothing
  92.             End If
  93.  
  94.         ' Initialize our COM object
  95.             Kernel32Handle = GetModuleHandleA("kernel32")
  96.             GetProcAddressPtr = GetProcAddress(Kernel32Handle, "GetProcAddress")
  97.             Call NewMouseHook.Init(Kernel32Handle, GetProcAddressPtr, Form.hwnd)
  98.  
  99.         ' Disable the scroll wheel by default.
  100.             NewMouseHook.Scroll = False
  101.  
  102.     Else
  103.  
  104.         Err.Raise ERR_OUT_OF_MEMORY
  105.  
  106.     End If
  107.  
  108. End Function
  109.  

And add the following to form on open event:

Expand|Select|Wrap|Line Numbers
  1. Private Sub Form_Open(Cancel As Integer)
  2. Static MouseHook As 
  3. Set MouseHook = NewMouseHook(Me)
  4. End Sub             

3 1670
munkee
374 256MB
Here you go mate a script I found weeks ago which works very good:

Place this inside a module:

Expand|Select|Wrap|Line Numbers
  1. Option Explicit
  2.  
  3. '   *****************************************************************************
  4. '   * ------------      MOUSE HOOK for Microsoft(r) Access VBA     ------------ *
  5. '   * ------------      (c) Wayne Phillips / iTech Masters 2009    ------------ *
  6. '   * ------------          http://www.everythingaccess.com        ------------ *
  7. '   *****************************************************************************
  8. '   *                                                                           *
  9. '   * This module exposes a function that creates an in-memory, COM-compatible  *
  10. '   * object that is written in native x86 code rather than VBA.                *
  11. '   *                                                                           *
  12. '   * The purpose of this module is to allow easy disabling of the mouse scroll *
  13. '   * wheel in Forms, without needing a DLL and without VBA problems usually    *
  14. '   * associated with subclassing windows:                                      *
  15. '   * http://support.microsoft.com/?kbid=278379                                 *
  16. '   *                                                                           *
  17. '   * - v1.2 28/08/2009 - now compatible with both VBA5 and VBA6 (Access 97+)   *
  18. '   * - v1.4 01/09/2009 - Scroll disabled by default, for convenience           *
  19. '   * - v1.5 04/12/2009 - now the methods Init and Scroll are case insensitive  *
  20. '   *                                                                           *
  21. '   * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*
  22. '   * All the benefits of using a native compiled DLL - without needing a DLL!  *
  23. '   *                                                                           *
  24. '   *   You are free to include this module in your project provided that you   *
  25. '   *  leave this copyright notice in place and that no modifications are made. *
  26. '   * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*
  27. '   * Instructions:                                                             *
  28. '   *                                                                           *
  29. '   *  Add the following code to your OnOpen event:                             *
  30. '   *                                                                           *
  31. '   *     Private Sub Form_Open(Cancel As Integer)                              *
  32. '   *         Static MouseHook As Object                                        *
  33. '   *         Set MouseHook = NewMouseHook(Me)                                  *
  34. '   *     End Sub                                                               *
  35. '   *                                                                           *
  36. '   *****************************************************************************
  37.  
  38. Private Declare Function VirtualAlloc Lib "kernel32" (ByVal Address As Long, ByVal Size As Long, ByVal AllocationType As Long, ByVal Protect As Long) As Long
  39. Private Declare Function GetModuleHandleA Lib "kernel32" (ByVal ProcName As String) As Long
  40. Private Declare Function GetProcAddress Lib "kernel32" (ByVal Module As Long, ByVal ProcName As String) As Long
  41. Private Declare Sub CopyMemoryAnsi Lib "kernel32" Alias "RtlMoveMemory" (ByVal Dest As Long, ByVal Source As String, ByVal Size As Long)
  42. Private Declare Sub CastToObject Lib "kernel32" Alias "RtlMoveMemory" (ByRef Dest As Object, ByRef Source As Long, ByVal Size As Long)
  43.  
  44. Private Const SIZEOF_PTR32              As Long = &H4
  45. Private Const PAGE_EXECUTE_RW           As Long = &H40
  46. Private Const MEM_RESERVE_AND_COMMIT    As Long = &H3000
  47. Private Const ERR_OUT_OF_MEMORY         As Long = &H7
  48.  
  49. Private Type IDispatchVTable
  50.     QueryInterface As Long
  51.     AddRef As Long
  52.     Release As Long
  53.     GetTypeInfoCount As Long
  54.     GetTypeInfo As Long
  55.     GetIDsOfNames As Long
  56.     Invoke As Long
  57. End Type
  58.  
  59. Public Function NewMouseHook(ByRef Form As Access.Form) As Object
  60.  
  61.     Dim NativeCode As String
  62.     Dim Kernel32Handle As Long
  63.     Dim GetProcAddressPtr As Long
  64.     Dim MouseHookAddr As Long
  65.     Dim MouseHookLoader As Object
  66.     Dim LoaderVTable As IDispatchVTable
  67.  
  68.     NativeCode = _
  69.             "XYQPSWQ[T_S\\[S\XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX- %uUPXX-īT[PXX-E%%ePXX-uu0E-uu0EPXX-eeE%PXX-%e%uPXX-eeE PXX-%eE PXXX@@fX<0tF4+&4+2'&,V/PCp@-''2V/5+1''3V/ys 1S CCCuRfI>_ltcDPC@KCQcBnIAGBqcDPO@GBE@KCqc@YMQHUqp@dQ^AAAAGBUBISExD]MQQ=OYHAQ@\EAA@eiQDeiQHMIqFeiQLMIqHeiQPMIqHeiQTMIqHeiQXucOAAAAMcY^AAAAIsEHDEQCAeE@AeEC?GGCPCXM@BeqDAAoAAEA@KMC@azC@IAaBB@Ax[AABAiqXAqa<QCC@UFLwREHTIAA@AA\jmIPdqpaxBA\\mITdQqcRmiEMKX^AAAAf\MAIAQcP  TKKp>RPQM@JMH@azA@IAaBRCAHAAA@qjE@AA>JAAAxnAA@qCB@AADMAAAtuAA@QTB@AAlNAAAhAAA@UtclNIpt^]P<[VPXKpcEp>bPpQcU ?bM ? ypCAuPqM@n_LKWDBCkoAtTPajbaA@AQ\MmYRxBY_tAQ\DMBqkbp>uPp>u@p>upq>u pcU ??rpscM ??QPucevdqPAAePWtclNIppbG<AAAAhB L@AQWIWE>sA]cE ?bU ?bMpnpDEpU?WE?KWE?KWD>FRaAU<_PxnYRxnYP<[M@Hmy>E ?bU ?bMpnpDE@z?WE?KWE?KWD>FRaAS<_PxnYRxnYP<[M@HMy>E ?bU ?bMpnpDEP^?WE?KWE?KWD>FRaAT=_PxnYRxnYP<[M@HAq>E ?bU ?bMpnpDEP\?WE?KWE?KWD>FRaAK=_PxnYRxnYP<[M@Haz>E ?bU ?bMpnpDE @?WE?KWE?KWD>FRaA@<_PxnYRxnYP<[M@HAq>E ?bU ?bMpnpDE@a?WE?KWE?KWD>FRaAY<_PxnYRxnYP<[M@Hut>E ?b" & _
  70.             "U ?bMpnpDEpW?WE?KWE?KWD>FRaAB>_PxnYRxnYP<[M@Hqq>E ?bU ?bMpnpDE@A?WE?KWE?KWD>FRaAK?_PxnYRxnYP<[M@HUt>E ?bU ?bMpnpDE@B?WE?KWE?KWD>FRaAC?_PxnYRxnYP<[M@HI=?E ?bU ?bMpnpDE@@?WE?KWE?KWD>FRaAK?_PxnYRxnYP<[M@HIp>E ?bU ?bMpnpDEPc?WE?KWE?KWD>FRaAU<_PxnYRxnYP<[M@Hq>?E ?bU ?bMpnpDEpa?WE?KWE?KWD>FRaAz<_PxnYRxnYP<[M@HQq>E ?bU ?bMpnpDE@A?WE?KWE?KWD>FRaAu<_PxnYRxnYP<[M@Hip>E ?bU ?bMpnpDEPo?WE?KWE?KWD>FRaAC=_PxnYRxnYP<[M@HAq>E ?bU ?bMpnpDE@A?WE?KWE?KWD>FRaA@=_PxnYRxnYP<[M@Hmy>E ?bU ?bMpnpDEPP?WE?KWE?KWD>FRaAL=_PxnYRxnYP<[M@Hey>E ?bU ?bMpnpDEpq?WE?KWE?KWD>FRaAC?_PxnYRxnYP<[M@HA=?E ?bU ?bMpnpDE@B?WE?KWE?KWD>FRaAy=_PxnYRxnYP<[M@Hiu>E ?bU ?bMpnpDE@C?WE?KWE?KWD>FRaAt<_PxnYRxnYP<[M@Haq>E ?bU ?bMpnpDEPA?WE?KWE?KWD>FRaAX=_PxnYRxnYP<[M@HMy>E ?bU ?bMpnpDE@q?WE?KWE?KWD>FRaAD=_PxnYRxnYP<[M@HEu>E ?bU ?bMpnpDEp;?WE?KWE?KWD>FRaAs>_PxnYRxnYP<[M@HMy>E ?bU ?bMpnpDE ^?WE?KWE?KWD>FRaAD=_PxnYRxnYP<[M@HAq>E ?bU ?bMpnpDEP\?WE?KWE?KWD>FRaAF=_PxnYRxnYP<[M@Hmy>E ?bU ?bMpnpDEPR?WE?KWE?KWD>FRaAL=_PxnYRxnYP<[M@" & _
  71.             "Hey>E ?bU ?bMpnpDE R?WE?KWE?KWD>FRaAD=_PxNRsIwE<ifL@@Aq[EPNFACMNs^EAIWE=KWD?KwE>FRQEK?_PxnYPxnYT<[M@Buu>E ?bM ?bEpnpDaAE?WE?KWD?KwE>FRQEA?_PxnYPxnYT<[M@Bev>E ?bM ?bEpnpDaAA?WE?KWD=JkAaa>?bE ?bUpNcLIq>E ?bM@>bAEM;HQs>KWD?KwE>HSQE?WE?KWE=KCPqjB@ab>?bM ?bEpNcTaq>E ?bU@>bJE];XAYy?oYPxnYT<cIBB=_PxnYRxnYP<[M@HUv>E ?bU ?bMpnpDEpN?WE?KWE?KWD>FRaAA?_PxnYRxnYP<[M@Hev>E ?bU ?bMpnpDE@@?WE?KWE=JCD@@K??KwE?KWE>HS@C?WE?KWD=KkE@AfOC@G??KWE?KWD>HsaA?WE?KwE=KGE@AbOEd=?bU ?bMpNcDEp>E ?bE@>bPPQqjb@ab>?bM ?bEpNcTaq>E ?bU ?bMpnpDEP\?WE?KWE?KWD>FRaAv=_PxnYRxnYP<[M@HEy>E ?bU ?bMpnpDEP_?WE?KWE?KWD>FRaAH=_PxnYRpjYQHQs>KWD?KwE>HSQE?WE?KWE=KCDCAjOC@K??KwE?KWE>HS@C?WE?KWD=KkECAfOE@G??KWE?KWD>HsaA?WE?KwE=KGECAbOGd=?bU ?bMpNcDEp>E ?bE ?bUpnpDIQ\?WE?KwE?KWE>FRACm=_PxnYTxnYR<[M@QEy>E ?bE ?bUpnpDIQ_?WE?KwE?KWE>FRACL=_PxnYTpjiSLAYy?oYPxnYT<cIBB=_PxnYRpnYQLEM;HQs>KWD?KwE>HSQE?WE?KWE=KCDBAjOE@K??KwE?KWE>HS@C?WE?KWD=KkEBAfOG@G??KWE?KWD>HsaA?WE?KwE?KWE>FRACu<_PxnYTxnYR<[M@QQs>E ?bE ?bUpnpDIqc?WE?KwE?KWE>" & _
  72.             "FRACE<_PxnYTxnYR<[M@Qq>?E ?bE ?bUpnpDIqc?WE?KwE?KWE>FRACP<_PxnYTxnYR<[M@QQq>E ?bE ?bUpnpDIQa?WE?KwE?KWE>FRACB>_PxnYTtnisAJ?@kElcDUHRs^EAABoAd=?bU ?bMpNcDEp>E ?bEP>bPFMyCmcqKsQ LL>Q@E]yBE]?HAYy?oYPxnYT<cIBB=_PxnYRtnYqAF?@ka=bTuIRs^EAAJoAAjNE@K??KwE?KWE>HS@C?WE?KWD<Kk]qbNqKQnI@Usu=G@Qq KQqxb@H?oYTxnYR<cI@Q=_PxnYPxnYT<[M@Bmy>E ?bM ?bEpnpDaQR?WE?KWD?KwE>FRQET=_PxnYPxnYT<[M@Bey>E ?bM ?bEpnpDaQE?WE?KWD?KwE>FRQEK?_PxnYPxnYT<[M@BUu>E ?bM ?bEpnpDaAD?WE?KWD?KwE>FRQEK?_PxnYPxnYT<[M@BAp>E ?bM ?bEpnpDaaU?WE?KWD?KwE>FRQEK?_PxnYPxnYT<[M@Biq>E ?bM ?bEpnpDaq>?WE?KWD?KwE>FRQEQ<_PxnYPxnYT<[M@BQq>E ?bM ?bEpnpDaqM?WE?KWD?KwE>FRQE@>_PxnYPxnYT<[M@Bet>E ?bM ?bEpnpDaQV?WE?KWD?KwE>FRQE[<_PxnYPxnYT<[M@BI=?E ?bM ?bEpnpDaAB?WE?KWD?KwE>FRQE@=_Px>_PtnYPtnR@XG?Q@= aXm>??oYTxnYR<[M@Qmy>E ?bE ?bUpnpDIQR?WE?KwE?KWE>FRACT=_PxnYTxnYR<[M@Q]=?E ?bE ?bUpnpDIQA?WE?KwE?KWE>FRAC@=_PxnYTxnYR<[M@QAq>E ?bE ?bUpnpDIAA?WE?KwE?KWE>FRAC@=_PxnYTxnYR<[M@Qaz>E ?bE ?bUpnpDIaA?WE?KwE?KWE>FRAC@<_PxnYTxnYR<[M@QAq>E ?bE ?b" & _
  73.             "UpnpDIAa?WE?KwE?KWE>FRACK?_PxnYTxnYR<[M@QA=?E ?bE ?bUpnpDIqc?WE?KwE?KWE>FRAC@>_PxnYTxnYR<[M@Qet>E ?bE ?bUpnpDIQV?WE?KwE?KWE>FRAC[<_PxnYTxnYR<[M@QI=?E ?bE ?bUpnpDIAB?WE?KwE?KWE>FRAC@=_PxnYTxnYR<[M@QAx>E ?bEp>bevtqUlIzQlYPHMIqDmIEIWD>KwE>CgF@@UVCKWECKWD>IKE@KC=b@nYR<oYA?GQW]HM@@AHePOTTKs?TCwFD@UvCxKAQ@AYW]ldqLAqcUpqaBRqcReYT<Oi_DAQ\ZezA@AAAKWEBIO= @rQOJ @\HEAGCCM@Al?<CkF@@Uf@KwEBIkE@KwEEAgFA@AAA@UvNAgF@@AAA@UfLAgFC@BAA@UVJAgFB@AAAFTFHKWE>KCD@AKMA@AAAKwEDIGpcEPpcPItcJ=_UDMBqYttWBrAAKwEEAgFA@QaA@UvNAgF@@AAA@UfLAgFC@BAA@UVJAgFB@AAAFTFHKWE>KCD@AKMA@AAAKwEDIGpcEPpcPItcJ=_UDMBqYttWBrAAKwEDGFAA@AAAxKAQ@Ayc@nIqYttWBrAAPWtclFtcE pa@RqcPeYT<oYR<OY_DAQ\ImYPHmYT<giQDmIqKC=bMp>bA=_AYtdqDAAePCXTKs? DR>TKWECCCM@KCPcUp>bMp> yPAAudqcE pcUp^cBPqcMp>?ImYP<OIO@=P aCAA@mYT<Oi_LAqBDSHA@AqcMp>bApqaxpCAt rcUp>bJpq>qpc[<oYP<oIUL=o]pmYR<oYQL=OUHlYT<oiSLMBqIGEJKWD>KkEBCgBAtxqcEp>bPpqcJEtcA=OUHmYT<oiSLmYQ@dYPxnYT<oiSDEY;DFAA@eYRtnYP<?O]LmYT<oiSLmYAPlIE?KDDKWE?KwE<Is_V[LIpDaGA@CAAj@QUS<OyKC=b@nYR" & _
  74.             "<oYA[lYx]HM@@AHeUlIzQlYPHMIqDmIEIWD>KC=b@bZA@@AaYtdqHAAePCXTKs_UKWECCCM@KCPcUp>b@nIqxGAQ@AYW]HME@AHePWtclFtcE pa@RqcPeYT<OY^TEA\JaZA@@AainRA@AqcU@pcJYwayeE\KmYPPmIEfLiOiTFXKwEEKGaXCcfANPFBKWDEKkaXCgfAnTFRKWEEKC YCkF@IPFBKwEEKGaXCcF@iTFLKWDEKkaXCgf@TPFBKWEEKC YCkf@tTFFKwEEKGaXCcFC@UFEKWDFGJQA@AAAsA];ABAA@mYTPmiCfLYOSPvBKWEEKC YCkr]OUYe@AAAKwEEKGaXCcfACPFBKWDEKkaXCgfAcTV_KWEEKC YCkF@RPFBKwEEKGaXCcF@rTVYKWDEKkaXCgf@OPFBKWEEKC YCkf@oTVSKwEEKGaXCcFCLPFBKWDEKkaXCgFClTVMKWEEKC YCkfCLPFBKwEEKGaXCcfClTVGKWDEKkaXCgFB@UVBKWEFGBaA@AAAsA=zVmYT\]mA?????cj@@IAakZqc@nIqsA]W]HMG@AXTKs? Db=bE pa@RqcPeYT<OY^LEqBEkiA@AqcMppay pAthAoNAaA@g_uCAAACwFI@QFCKWDIf\mAAAqcMppcAYNQaAE\OmYT\miCKGEKKCPcU ?zKmYR\mYAKCDKIWD?KwEFKGa<@D@Qt<pcUppcJmYQXmIEIWD<knqcMppcAmIUXeYTtnYR<OYqnDt>u ??UP^cE@>bEp> @>GU?WD=IWEzKWD>AK] @AAAR<_TpfYPhnYR<GYqNCAA@Et>up??UP^cEP_bE@OUjDq>UPo[PlYT KtcJ=_ULmYT<giQLmYP<Wag@AAAP<_TpnYR<oYULeiQdmYP<WQi@AAAPlYR<oYQL=O]d=_TtnYT<oiSLeYQDlYP<WQm@AAAPlYT<oiSL=_]d=_TtnYT<oiSLeYQHlYP" & _
  75.             "<oIQLMbuICDKse]cMp<bEppcPeYTXnYRX>plAubA@@AA?E@\ALI;BQFMHPVDCcoBtHu;ZtsA@@AAtHpahzA\AlORKWDwKkECIwEvkFucE =bP pcJeYR\nOLKWEwO=KUHeYT\nOKKwEwKGECO=KEIWDvkjpcM =L@jYQHeYP\n_BKWDwKkECsAmcAeYP\nYT<oiSLmYP\fYQpmYT<oiSLY]QtEqcEp^@@BAA@At>u ??UP>bUp>bJpQcA@ucEp>bPpqcM@_cJmYP<oIULmYRpfiS<lYP<oIULmYRtfiSxmYP<oIULmYRxfiSXmYP<oIULmYRlfiS\mYP<oIULmYRhfiS lYP<oIULmYRHeiShmYPHmIEKkEFIwEtsA]cE@<bUP<@U@\azYVPXKP\MmYRTNQRPnYP<gYAkrq>E@\a=ALs@AAA<e<?uPl[<oYT<oiSL=_]pmYP<oIUL=oUHlYR<oYULeiQlMBqi>UA@AQ;MDAA@MY^LIqBEOUA@AaXCwFGBQfBfLY^XMA\GYwa=aPAuxucMppay @AthAoNAaA@gOKAAAACwFI@QFHKWDIf\mAKAqcMp>bApAaxPBAtTqaJ>?zBMbuKWEIfdIUHmoCx;@ABAY;tBAA@MBqivOA@AaXCwFGD=P UBAA@mYT\Mi_HEA\JajB@IAai>LA@AqMRfYTLnYR\mYAIWEsKWDsO]jCAgnA@@AA?Y@\LLY;BQvOIPFICgOCtdwaiZA\Hlo_Ag?@@@AAt\paibA\aLY;FQVQkZwcE <bP PcUp=z[lYRHnYQHmIEIWDrkzucM <C?FECIWErkJucU <bJ pB?FQcEp=ztmYTHNRsJkECIwErk^scE <bP pMIjiCIwErkbpcE <C?BDCIWDrkrqcM <bA pB?BPcUp= =qMAOUXqCG_AKWE>KCDBHkELsA=zMazA@IAakZqc@nIqsA=bevdqdAAePCHA@AAA@AAA@iAA" & _
  76.             "@AAA@AAAC@qZ@AFAy@a]@eGAg@A[@QFA @qT@EGAy@aZ@UGA @AU@aGAi@AZ@qGAi@A]@MFA @qJ@ACAi@AT@UGAc@A[@ACAM@QY@MFAt@QX@IFAs@AI@IBApAAM@aBA@AAA@]UXttuZdTFZe TYnPGZeDEAOpUPsIBAOpUPATF\sIBAC<vPePVRapGZoLGAULTPRLbM@MUYlpwTixGXo\FUr<vYA@qUePvTixGXo\FRoxwXA@aTiHF\uDGZFHVXe@AA0"
  77.  
  78.     ' Allocate the executable memory for the object
  79.         MouseHookAddr = VirtualAlloc(0, Len(NativeCode), MEM_RESERVE_AND_COMMIT, PAGE_EXECUTE_RW)
  80.  
  81.     If MouseHookAddr <> 0 Then
  82.  
  83.         ' Copy the x86 native code into the allocated memory
  84.             Call CopyMemoryAnsi(MouseHookAddr, NativeCode, Len(NativeCode))
  85.  
  86.         ' Force the memory address into an Object variable (also triggers the shell code)
  87.             LoaderVTable.QueryInterface = MouseHookAddr
  88.             Call CastToObject(MouseHookLoader, VarPtr(VarPtr(LoaderVTable)), SIZEOF_PTR32)
  89.             If Not TypeOf MouseHookLoader Is VBA.Collection Then
  90.                 Set NewMouseHook = (MouseHookLoader)
  91.                 Set MouseHookLoader = Nothing
  92.             End If
  93.  
  94.         ' Initialize our COM object
  95.             Kernel32Handle = GetModuleHandleA("kernel32")
  96.             GetProcAddressPtr = GetProcAddress(Kernel32Handle, "GetProcAddress")
  97.             Call NewMouseHook.Init(Kernel32Handle, GetProcAddressPtr, Form.hwnd)
  98.  
  99.         ' Disable the scroll wheel by default.
  100.             NewMouseHook.Scroll = False
  101.  
  102.     Else
  103.  
  104.         Err.Raise ERR_OUT_OF_MEMORY
  105.  
  106.     End If
  107.  
  108. End Function
  109.  

And add the following to form on open event:

Expand|Select|Wrap|Line Numbers
  1. Private Sub Form_Open(Cancel As Integer)
  2. Static MouseHook As 
  3. Set MouseHook = NewMouseHook(Me)
  4. End Sub             
Sep 20 '10 #2
Dear munkee!
thanks for your answer. I already made the answer. But after Insert a module to paste " Option Explicit....End Function" content and add to form on open event
" Static MouseHook As
Set MouseHook = NewMouseHook(Me)"
When I opened form then that form closed automatic.
I don't understand?
Please support me!
Thanks very much!
Sep 20 '10 #3
munkee
374 256MB
Might be worth posting all of your code for the form and I will take a look, or a sample of the database.
Sep 20 '10 #4

Post your reply

Sign in to post your reply or Sign up for a free account.

Similar topics

10 posts views Thread by Geoff | last post: by
1 post views Thread by CARIGAR | last post: by
1 post views Thread by Mortomer39 | last post: by
By using this site, you agree to our Privacy Policy and Terms of Use.