home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 5_2007-2008.ISO / data / Zips / SelfSub__S2076517212007.psc / clsAPIwindow_Template.cls < prev   
Text File  |  2007-07-15  |  41KB  |  686 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "clsAPIwindow_Template"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. Option Explicit
  15.  
  16. ' This class is designed to be used to register/unregister
  17. ' custom window classes (i.e., ALL - API Windows). And also
  18. ' can be used to create windows using CreateWindowEx
  19.  
  20. ' The class is also designed in a way that you can instantiate
  21. ' it just to create something or to destroy something, then
  22. ' terminate the class so you don't need to keep it alive.
  23. ' The only exception is that if you choose to register the
  24. ' custom window class assigning this class as its window procedure,
  25. ' then you would need to keep this class alive until the
  26. ' custom class was unregistered.
  27.  
  28. ' NOTE: MANY OF THESE ROUTINES ARE IDENTICAL OR VERY SIMILAR TO THOSE
  29. ' FOR SELF-SUBCLASSING. HOWEVER, DON'T ASSUME THEY ARE THE SAME.
  30. ' Some key differences include:
  31. '   scc_AddMsg & scc_DelMsg is by ClassName not hWnd
  32. '   scc_lParamUser property is by ClassName not hWnd
  33. '   zMap_VFunction uses ClassName not hWnd
  34.  
  35. ' This class inspired by Paul Caton's APIWindow ASM project found
  36. ' on vbAccelerator. However, the ASM is based off his self-sub ASM
  37. ' code not that from vbAccelerator
  38.  
  39. ' Routines overview. See the comments in those routines for more information
  40. ' ==========================================================================
  41. ' scc_CreateWindow - creates a window based off a passed window class name
  42. ' scc_RegClassProc - registers a new window class and assigns a window procedure for that class
  43. ' scc_UnRegisterClassProc - unregisters a window class and frees memory associated with it
  44. ' scc_AddMsg - adds a window message to be processed within the class window procedure
  45. ' scc_DelMsg - removes a window message from being processed within the procedure
  46. ' scc_lParamUser (let/get property) - sets/gets custom parameter assigned when calling scc_RegClassProc
  47. ' zALL_API_WndProc - routine prototype to be used for the window procedure
  48.  
  49. Private Declare Function CreateWindowExA Lib "user32.dll" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, ByRef lpParam As Any) As Long
  50. Private Declare Function CreateWindowExW Lib "user32.dll" (ByVal dwExStyle As Long, ByVal lpClassName As Long, ByVal lpWindowName As Long, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, ByRef lpParam As Any) As Long
  51.  
  52. ' Following are possible window and class styles
  53. Public Enum eWindowStyle
  54.         WS_OVERLAPPED = &H0
  55.         WS_POPUP = &H80000000
  56.         WS_CHILD = &H40000000
  57.         WS_MINIMIZE = &H20000000
  58.         WS_VISIBLE = &H10000000
  59.         WS_DISABLED = &H8000000
  60.         WS_CLIPSIBLINGS = &H4000000
  61.         WS_CLIPCHILDREN = &H2000000
  62.         WS_MAXIMIZE = &H1000000
  63.         WS_CAPTION = &HC00000
  64.         WS_BORDER = &H800000
  65.         WS_DLGFRAME = &H400000
  66.         WS_VSCROLL = &H200000
  67.         WS_HSCROLL = &H100000
  68.         WS_SYSMENU = &H80000
  69.         WS_THICKFRAME = &H40000
  70.         WS_GROUP = &H20000
  71.         WS_TABSTOP = &H10000
  72.         WS_MINIMIZEBOX = &H20000
  73.         WS_MAXIMIZEBOX = &H10000
  74.         WS_TILED = &H0
  75.         WS_ICONIC = &H20000000
  76.         WS_SIZEBOX = &H40000
  77.         WS_OVERLAPPEDWINDOW = &HCF0000
  78.         WS_POPUPWINDOW = &H80880000
  79. End Enum
  80. Public Enum eWindowStyleEx
  81.         WS_EX_DLGMODALFRAME = &H1
  82.         WS_EX_NOPARENTNOTIFY = &H4
  83.         WS_EX_TOPMOST = &H8
  84.         WS_EX_ACCEPTFILES = &H10
  85.         WS_EX_TRANSPARENT = &H20
  86.         WS_EX_MDICHILD = &H40
  87.         WS_EX_TOOLWINDOW = &H80
  88.         WS_EX_WINDOWEDGE = &H100
  89.         WS_EX_CLIENTEDGE = &H200
  90.         WS_EX_CONTEXTHELP = &H400
  91.         WS_EX_RIGHT = &H1000
  92.         WS_EX_LEFT = &H0
  93.         WS_EX_RTLREADING = &H2000
  94.         WS_EX_LTRREADING = &H0
  95.         WS_EX_LEFTSCROLLBAR = &H4000
  96.         WS_EX_RIGHTSCROLLBAR = &H0
  97.         WS_EX_CONTROLPARENT = &H10000
  98.         WS_EX_STATICEDGE = &H20000
  99.         WS_EX_APPWINDOW = &H40000
  100.         WS_EX_OVERLAPPEDWINDOW = &H300
  101.         WS_EX_PALETTEWINDOW = &H188
  102.         WS_EX_LAYERED = &H80000
  103. End Enum
  104. Public Enum eClassStyle
  105.         CS_VREDRAW = 1
  106.         CS_HREDRAW = 2
  107.         CS_KEYCVTWINDOW = 4
  108.         CS_DBLCLKS = 8
  109.         CS_OWNDC = 32
  110.         CS_CLASSDC = 64
  111.         CS_PARENTDC = 128
  112.         CS_NOKEYCVT = 256
  113.         CS_NOCLOSE = 512
  114.         CS_SAVEBITS = 2048
  115.         CS_BYTEALIGNCLIENT = 4096
  116.         CS_BYTEALIGNWINDOW = 8192
  117.         CS_PUBLICCLASS = 16384
  118. End Enum
  119.  
  120. Private Declare Function CreateSolidBrush Lib "gdi32.dll" (ByVal crColor As Long) As Long
  121. Private Declare Function GetClassInfoExA Lib "user32.dll" (ByVal hInstance As Long, ByVal lpcstr As String, ByRef lpwndclassexa As WNDCLASSEX) As Long
  122. Private Declare Function GetClassInfoExW Lib "user32.dll" (ByVal hInstance As Long, ByVal lpcstr As Long, ByRef lpwndclassexa As WNDCLASSEX) As Long
  123. Private Declare Function RegisterClassExA Lib "user32.dll" (ByRef pcWndClassEx As WNDCLASSEX) As Long
  124. Private Declare Function RegisterClassExW Lib "user32.dll" (ByRef pcWndClassEx As WNDCLASSEX) As Long
  125. Private Declare Function UnregisterClassA Lib "user32.dll" (ByVal lpClassName As String, ByVal hInstance As Long) As Long
  126. Private Declare Function UnregisterClassW Lib "user32.dll" (ByVal lpClassName As Long, ByVal hInstance As Long) As Long
  127.  
  128. Private Type WNDCLASSEX
  129.     cbSize As Long
  130.     Style As Long
  131.     lpfnWndProc As Long
  132.     cbClsExtra As Long
  133.     cbWndExtra As Long
  134.     hInstance As Long
  135.     hIcon As Long
  136.     hCursor As Long
  137.     hbrBackground As Long
  138.     lpszMenuName As String   'not generally used. Add code for it if needed.
  139.     lpszClassName As Long    'pointer
  140.     hIconSm As Long
  141. End Type
  142.  
  143.     
  144. ' ***** THUNK APIs and VARIABLES
  145. Private Declare Sub RtlMoveMemory Lib "kernel32" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
  146. Private Declare Function IsBadCodePtr Lib "kernel32" (ByVal lpfn As Long) As Long
  147. Private Declare Function VirtualAlloc Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
  148. Private Declare Function VirtualFree Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long
  149. Private Declare Function GetModuleHandleA Lib "kernel32" (ByVal lpModuleName As String) As Long
  150. Private Declare Function GetModuleHandleW Lib "kernel32" (ByVal lpModuleName As Long) As Long
  151. Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
  152. Private Declare Function IsWindowUnicode Lib "user32.dll" (ByVal hwnd As Long) As Long
  153. Private Declare Function GetDesktopWindow Lib "user32.dll" () As Long
  154.     
  155. Private z_ScMem             As Long        'Thunk base address
  156.  
  157. Private Const IDX_CALLBACK   As Long = 7   'Thunk data index of the custom class window proc
  158. Private Const IDX_BTABLE    As Long = 8    'Thunk data index of the Before table for messages
  159. Private Const IDX_ATABLE    As Long = 9    'Thunk data index of the After table for messages
  160. Private Const IDX_PARMUSER  As Long = 10   'Thunk data index of the user-defined parameter
  161. Private Const IDX_EBX       As Long = 13   'Thunk code patch index of the thunk data
  162. Private Const IDX_UNICODE   As Long = 64   'Must be UBound(thunk data)+1, index of Unicode usage
  163. Private Const WNDPROC_OFF   As Long = &H2C 'Offset where window proc starts from z_ScMem
  164. Private Const MSG_ENTRIES   As Long = 32   'Number of msg table entries. Set to 1 if using ALL_MESSAGES for all custom windows
  165.  
  166. Public Enum sccMsgWhen                            'When to callback
  167.   MSG_BEFORE = 1                                'Callback before the original WndProc
  168.   MSG_AFTER = 2                                 'Callback after the original WndProc
  169.   MSG_BEFORE_AFTER = MSG_BEFORE Or MSG_AFTER    'Callback before and after the original WndProc
  170. End Enum
  171. Public Enum sccALLMessages
  172.     ALL_MESSAGES = -1                           'All messages will callback
  173. End Enum
  174.  
  175. Public Function scc_CreateWindow(ByVal sClass As String, _
  176.                         ByVal Style As eWindowStyle, _
  177.                         Optional ByVal StyleEx As eWindowStyleEx, _
  178.                         Optional ByVal sCaption As String = vbNullString, _
  179.                         Optional ByVal Width As Long = 0, _
  180.                         Optional ByVal Height As Long = 0, _
  181.                         Optional ByVal Left As Long = 0, _
  182.                         Optional ByVal Top As Long = 0, _
  183.                         Optional ByVal ParentHWnd As Long = 0, _
  184.                         Optional ByVal MenuHandle As Long = 0, _
  185.                         Optional ByRef bUnicode As Boolean) As Long
  186.     
  187.     ' Function added as a courtesy. Contains everything you need to create an API window
  188.     '*************************************************************************************************
  189.     '* sClass - The class to create the window from
  190.     '* Style - a combination of valid window styles.
  191.     '* StyleEx - a combination of valid extended window styles
  192.     '* sCaption - the window caption
  193.     '* Width - the window's width (pixels)
  194.     '* Height - the window's height (pixels)
  195.     '* Left - the left position of the window in screen or client coords (pixels)
  196.     '* Top - the top position of the window in screen or client coords (pixels)
  197.     '* ParentHWnd - handle to the window's parent if window is a child window
  198.     '* MenuHandle - menubar handle for the window
  199.     '* bUnicode - Optional, if True, Unicode API calls should be made to the window vs ANSI calls
  200.     '*            Parameter is byRef and its return value should be checked to know if ANSI to be used or not
  201.     '*************************************************************************************************
  202.                         
  203.     If bUnicode Then bUnicode = (IsWindowUnicode(GetDesktopWindow) <> 0)
  204.     If bUnicode Then
  205.         scc_CreateWindow = CreateWindowExW(StyleEx, StrPtr(sClass), StrPtr(sCaption), Style, _
  206.                 Left, Top, Width, Height, ParentHWnd, MenuHandle, App.hInstance, ByVal 0&)
  207.     Else
  208.         scc_CreateWindow = CreateWindowExA(StyleEx, sClass, sCaption, Style, _
  209.                 Left, Top, Width, Height, ParentHWnd, MenuHandle, App.hInstance, ByVal 0&)
  210.     End If
  211.                         
  212. End Function
  213.  
  214. Public Function scc_RegClassProc(ByVal sClass As String, _
  215.                     Optional ByVal BackColor As Long = vbButtonFace, _
  216.                     Optional ByVal Style As eClassStyle = 0, _
  217.                     Optional ByVal hCursor As Long = 0, _
  218.                     Optional ByVal hIcon As Long = 0, _
  219.                     Optional ByVal hIconSm As Long = 0, _
  220.                     Optional ByVal cbClassExtra As Long = 0, _
  221.                     Optional ByVal cbWndExtra As Long = 0, _
  222.                     Optional ByVal lParamUser As Long = 0, _
  223.                     Optional ByVal nOrdinal As Long = 1, _
  224.                     Optional ByVal oCallback As Object = Nothing, _
  225.                     Optional ByVal bIdeSafety As Boolean = True, _
  226.                     Optional ByRef bUnicode As Boolean = False) As Boolean
  227.  
  228.     '*************************************************************************************************
  229.     '* Following are class creation properties
  230.     '* sClass - A unicode or non-unicode class name. If unicode, and unicode class creation
  231.     '           is not used, string is converted from unicode. Vice versa applies too
  232.     '* BackColor - either system color or RGB color for the default window bkg color of the class
  233.     '* Style - a combination of valid class styles.
  234.     '* hCursor - a default cursor to use when in client area: Use LoadCursor and pass handle
  235.     '* hIcon - a 32x32 icon to use. Use LoadIcon and pass handle
  236.     '* hIconSm - a 16x16 icon to use (system menu). Use LoadIcon and pass handle
  237.     '* cbClassExtra - Set/Retrieved via GetClassLong API
  238.     '* cbWndExtra - Set/Retrieved via GetWindowLong API
  239.     '
  240.     '* Following are used to regsiter the class and create its window procedure
  241.     '* lParamUser - Optional, user-defined callback parameter
  242.     '* nOrdinal   - Optional, ordinal index of the callback procedure. 1 = last private method, 2 = second last private method, etc.
  243.     '* oCallback  - Optional, the object that will receive the callback. If undefined, callbacks are sent to this object's instance
  244.     '* bIdeSafety - Optional, enable/disable IDE safety measures
  245.     '* bUnicode - Optional, if True, Unicode API calls should be made to the class vs ANSI calls
  246.     '*            Parameter is byRef and its return value should be checked to know whether ANSI used or not
  247.     '*************************************************************************************************
  248.     ' Subclassing procedure must be declared identical to the one at the end of this class (Sample at Ordinal #1)
  249.  
  250.     Dim z_Sc(0 To IDX_UNICODE) As Long                 'Thunk machine-code initialised here
  251.     Dim CODE_LEN      As Long                          'Thunk length in bytes
  252.     Dim MEM_LEN       As Long                          'Bytes to allocate per thunk, data + code + msg tables
  253.     
  254.     Const PAGE_RWX      As Long = &H40&                'Allocate executable memory
  255.     Const MEM_COMMIT    As Long = &H1000&              'Commit allocated memory
  256.     Const MEM_RELEASE   As Long = &H8000&              'Release allocated memory flag
  257.     Const IDX_NOPROCEDURE As Long = 1                  'Occurs when IDE stops while class is still active
  258.     Const IDX_EBMODE    As Long = 2                    'Thunk data index of the EbMode function address
  259.     Const IDX_DWP       As Long = 3                    'Thunk data index of the DefWindowProc function address
  260.     Const IDX_DW        As Long = 4                    'Thunk data index of the DestroyWindow function address
  261.     Const IDX_BADPTR    As Long = 5                    'Thunk data index of the IsBadCodePtr function address
  262.     Const IDX_OWNER     As Long = 6                    'Thunk data index of the Owner object's vTable address
  263.     Const SUB_NAME      As String = "scc_Subclass"     'This routine's name
  264.     
  265.     Dim nAddr         As Long
  266.     Dim aClass()      As Byte
  267.     Dim bIDE          As Boolean
  268.     Dim WC As WNDCLASSEX
  269.  
  270.     If oCallback Is Nothing Then Set oCallback = Me     'If the user hasn't specified the callback owner
  271.     
  272.     nAddr = zAddressOf(oCallback, nOrdinal)             'Get the address of the specified ordinal method
  273.     If nAddr = 0 Then                                   'Ensure that we've found the ordinal method
  274.       zError SUB_NAME, "Callback method not found"
  275.       Exit Function
  276.     End If
  277.         
  278.     If zMap_VFunction(sClass, True) = 0& Then           ' See if this class is already registered
  279.         zError SUB_NAME, "Class is not one registered by this application. Cannot modify it"
  280.         Exit Function
  281.     ElseIf Not z_ScMem = -1 Then                        ' class exists, try to unregister it first
  282.         If scc_UnRegisterClassProc(sClass) = True Then z_ScMem = -1
  283.     End If
  284.     
  285.     If z_ScMem = -1 Then                                ' class not previously registered
  286.     
  287.         ' Validate unicode request
  288.         If bUnicode Then bUnicode = (IsWindowUnicode(GetDesktopWindow) <> 0)
  289.         ' Add class name to array for use in registration
  290.         If bUnicode Then
  291.             CODE_LEN = Len(sClass) * 2 + 2
  292.             ReDim aClass(0 To CODE_LEN - 1)
  293.             RtlMoveMemory VarPtr(aClass(0)), StrPtr(sClass), CODE_LEN - 2
  294.         Else
  295.             aClass = StrConv(sClass & vbNullChar, vbFromUnicode)
  296.         End If
  297.         
  298.         ' calculate memory size requirements
  299.         CODE_LEN = IDX_UNICODE * 4 + 4
  300.         MEM_LEN = CODE_LEN + (8 * MSG_ENTRIES + 8)
  301.             
  302.         z_ScMem = VirtualAlloc(0, MEM_LEN, MEM_COMMIT, PAGE_RWX) 'Allocate executable memory
  303.         If z_ScMem <> 0 Then                                     'Ensure the allocation succeeded
  304.         
  305.             If z_ScMem < WNDPROC_OFF Then
  306.                 
  307.                 zError SUB_NAME, "Negative memory address. Class not designed to handle these. Report this to author"
  308.                 GoTo ReleaseMemory
  309.                 
  310.             Else
  311.           
  312.               ' actual thunk data
  313.               z_Sc(11) = &HD231C031: z_Sc(12) = &HBBE58960: z_Sc(13) = &H12345678: z_Sc(14) = &H4339F631: z_Sc(15) = &H902D7508: z_Sc(16) = &H207B8B4A: z_Sc(17) = &HE81C7589: z_Sc(18) = &H6C&: z_Sc(19) = &H75147539: z_Sc(20) = &H90909017: z_Sc(21) = &H37E8&: z_Sc(22) = &H90909000: z_Sc(23) = &H7B8BD231: z_Sc(24) = &H52E824: z_Sc(25) = &H90900000: z_Sc(26) = &H10C261: z_Sc(27) = &H74047339: z_Sc(28) = &H1AE807: z_Sc(29) = &HF0EB0000: z_Sc(30) = &H3D0853FF: z_Sc(31) = &H1&: z_Sc(32) = &HC085BE74: z_Sc(33) = &H5E82274: z_Sc(34) = &HEB000000: z_Sc(35) = &H909090DB: z_Sc(36) = &HFF3075FF: z_Sc(37) = &H75FF2C75: z_Sc(38) = &H2475FF28: z_Sc(39) = &H890C53FF: z_Sc(40) = &H55E91C45: z_Sc(41) = &H90000000: z_Sc(42) = &H10443C7: z_Sc(43) = &HFF000000: z_Sc(44) = &H53FF2475: z_Sc(45) = &H90B1EB10: z_Sc(46) = &H40E30F8B: z_Sc(47) = &H1078C985: z_Sc(48) = &H4C781: z_Sc(49) = &H458B0000
  314.               z_Sc(50) = &H75AFF228: z_Sc(51) = &H9090902F: z_Sc(52) = &H1C73FF52: z_Sc(53) = &H5A1453FF: z_Sc(54) = &H438D2275: z_Sc(55) = &H144D8D28: z_Sc(56) = &H1C458D50: z_Sc(57) = &HFF3075FF: z_Sc(58) = &H75FF2C75: z_Sc(59) = &H2475FF28: z_Sc(60) = &HFF525150: z_Sc(61) = &H53FF1873: z_Sc(62) = &H9090901C: z_Sc(63) = &HC3&
  315.               
  316.               z_Sc(IDX_EBX) = z_ScMem                                       'Patch the thunk data address
  317.               z_Sc(IDX_BTABLE) = z_Sc(IDX_EBX) + CODE_LEN                   'Store the address of the before table in the thunk data
  318.               z_Sc(IDX_ATABLE) = z_Sc(IDX_BTABLE) + (MSG_ENTRIES * 4) + 4   'Store the address of the after table in the thunk data
  319.               z_Sc(IDX_OWNER) = ObjPtr(oCallback)                           'Store the callback owner's object address in the thunk data
  320.               z_Sc(IDX_CALLBACK) = nAddr                                    'Store the callback address in the thunk data
  321.               z_Sc(IDX_PARMUSER) = lParamUser                               'Store the lParamUser callback parameter in the thunk data
  322.               z_Sc(IDX_UNICODE) = Abs(bUnicode)                             'Store whether unicode is used or not
  323.               z_Sc(0) = z_Sc(IDX_EBX)                                       'Used to help validate this is our custom class
  324.               
  325.               z_Sc(IDX_BADPTR) = zFnAddr("kernel32", "IsBadCodePtr", bUnicode) 'Store the IsBadCodePtr function address in the thunk data
  326.               z_Sc(IDX_DW) = zFnAddr("user32", "DestroyWindow", bUnicode)   'Store the DestroyWindow function address in the thunk data
  327.               
  328.               If bIdeSafety = True Then                                     'If the user wants IDE protection
  329.                   Debug.Assert zInIDE(bIDE)
  330.                   If bIDE = True Then z_Sc(IDX_EBMODE) = zFnAddr("vba6", "EbMode", bUnicode) 'Store the EbMode function address in the thunk data
  331.               End If
  332.               
  333.               If bUnicode Then                                               'Store the DefWindowProc function address in the thunk data
  334.                   z_Sc(IDX_DWP) = zFnAddr("user32", "DefWindowProcW", bUnicode)
  335.               Else
  336.                   z_Sc(IDX_DWP) = zFnAddr("user32", "DefWindowProcA", bUnicode)
  337.               End If
  338.               RtlMoveMemory z_Sc(IDX_EBX), VarPtr(z_Sc(0)), CODE_LEN         'Copy the thunk code/data to the allocated memory
  339.           
  340.              'fill in the window class structure
  341.              With WC
  342.                  .cbSize = Len(WC)
  343.                  If cbClassExtra > 0 Then .cbClsExtra = cbClassExtra
  344.                  If cbWndExtra > 0 Then .cbWndExtra = cbWndExtra
  345.                  .hCursor = hCursor
  346.                  .hIcon = hIcon
  347.                  .hIconSm = hIconSm
  348.                  .hInstance = App.hInstance
  349.                  .lpszClassName = VarPtr(aClass(0))
  350.                  .Style = Style
  351.                  .lpfnWndProc = z_Sc(IDX_EBX) + WNDPROC_OFF
  352.                   If (BackColor \ &H80FFFFFF) Then
  353.                     ' convert vb system color constant to windows system color constant + 1
  354.                       .hbrBackground = (BackColor And &HFF&) + 1
  355.                   Else
  356.                       .hbrBackground = CreateSolidBrush(BackColor)
  357.                   End If
  358.              End With
  359.              
  360.              'Attempt to register the window
  361.              If bUnicode Then
  362.                If RegisterClassExW(WC) = 0 Then GoTo ReleaseMemory
  363.              Else
  364.                If RegisterClassExA(WC) = 0 Then GoTo ReleaseMemory
  365.             End If
  366.             scc_RegClassProc = True
  367.           End If
  368.           
  369.         Else
  370.           zError SUB_NAME, "VirtualAlloc failed, error: " & Err.LastDllError
  371.         End If
  372.     
  373.     Else
  374.         ' should this happen. An attempt is being made to register a pre-existing
  375.         ' class which cannot be unregistered (usually means a window created with
  376.         ' that class still exists). We can update two key procedure attributes:
  377.         
  378.         zData(IDX_CALLBACK) = nAddr             'Set/change the window procedure
  379.         zData(IDX_NOPROCEDURE) = 0              'Ensure procedure override is false
  380.         scc_RegClassProc = True
  381.         
  382.     End If
  383.     
  384. Exit Function                                   'Exit
  385. ReleaseMemory:
  386.       VirtualFree z_ScMem, 0, MEM_RELEASE       'scc_Subclass has failed after memory allocation, so release the memory
  387. End Function
  388.  
  389. Public Function scc_UnRegisterClassProc(ByVal sClass As String) As Boolean
  390.     ' function unregisters a class if possible.
  391.     ' If any windows are currently not destroyed that were created from the passed
  392.     ' class, then unregistering will fail. Regardless, the class is always unregistered
  393.     ' by windows when the app's instance is terminated. Likewise, since the class'
  394.     ' window procedure is virtual memory, virtual memory is also destroyed at that
  395.     ' point too. Bottom line, can't cause memory leaks whether unregistered or not
  396.     If IsBadCodePtr(zMap_VFunction(sClass, False)) = 0 Then
  397.         If zData(IDX_UNICODE) Then
  398.             scc_UnRegisterClassProc = UnregisterClassW(StrPtr(sClass), App.hInstance)
  399.         Else
  400.             scc_UnRegisterClassProc = UnregisterClassA(sClass, App.hInstance)
  401.         End If
  402.         ' if we unregistered the class, release its memory too
  403.         If scc_UnRegisterClassProc = True Then
  404.             Const MEM_RELEASE As Long = &H8000&             'Release allocated memory flag
  405.             VirtualFree z_ScMem, 0, MEM_RELEASE
  406.         End If
  407.     End If
  408. End Function
  409.  
  410. 'Add the message value to the window handle's specified callback table
  411. Public Sub scc_AddMsg(ByVal ClassName As String, ByVal When As sccMsgWhen, ParamArray Messages() As Variant)
  412.     
  413.     If IsBadCodePtr(zMap_VFunction(ClassName, False)) = 0 Then              'Ensure that the thunk hasn't already released its memory
  414.       Dim M As Long
  415.       For M = LBound(Messages) To UBound(Messages)                          ' ensure no strings, arrays, doubles, objects, etc are passed
  416.         Select Case VarType(Messages(M))
  417.         Case vbByte, vbInteger, vbLong
  418.             If When And MSG_BEFORE Then                                     'If the message is to be added to the before original WndProc table...
  419.               zAddMsg Messages(M), IDX_BTABLE                               'Add the message to the before table
  420.             End If
  421.             If When And MSG_AFTER Then                                      'If message is to be added to the after original WndProc table...
  422.               zAddMsg Messages(M), IDX_ATABLE                               'Add the message to the after table
  423.             End If
  424.         End Select
  425.       Next
  426.     End If
  427.  
  428. End Sub
  429.  
  430. 'Delete the message value from the window handle's specified callback table
  431. Public Sub scc_DelMsg(ByVal ClassName As String, ByVal When As sccMsgWhen, ParamArray Messages() As Variant)
  432.     
  433.     If IsBadCodePtr(zMap_VFunction(ClassName, False)) = 0 Then              'Ensure that the thunk hasn't already released its memory
  434.       Dim M As Long
  435.       For M = LBound(Messages) To UBound(Messages)                          ' ensure no strings, arrays, doubles, objects, etc are passed
  436.         Select Case VarType(Messages(M))
  437.         Case vbByte, vbInteger, vbLong
  438.             If When And MSG_BEFORE Then                                     'If the message is to be added to the before original WndProc table...
  439.               If zAddMsg(Messages(M), IDX_BTABLE) = False Then              'Add the message to the before table
  440.                 When = When And Not MSG_BEFORE
  441.               End If
  442.             End If
  443.             If When And MSG_AFTER Then                                      'If message is to be added to the after original WndProc table...
  444.               If zAddMsg(Messages(M), IDX_ATABLE) = False Then              'Add the message to the after table
  445.                 When = When And Not MSG_AFTER
  446.               End If
  447.             End If
  448.         End Select
  449.       Next
  450.     End If
  451.  
  452. End Sub
  453.  
  454. 'Get the subclasser lParamUser callback parameter
  455. Public Property Get scc_lParamUser(ByVal ClassName As String) As Long
  456.     If IsBadCodePtr(zMap_VFunction(ClassName, False)) = 0 Then        'Ensure that the thunk hasn't already released its memory
  457.       scc_lParamUser = zData(IDX_PARMUSER)                        'Get the lParamUser callback parameter
  458.     End If
  459. End Property
  460.  
  461. 'Let the subclasser lParamUser callback parameter
  462. Public Property Let scc_lParamUser(ByVal ClassName As String, ByVal newValue As Long)
  463.     If IsBadCodePtr(zMap_VFunction(ClassName, False)) = 0 Then        'Ensure that the thunk hasn't already released its memory
  464.       zData(IDX_PARMUSER) = newValue                              'Set the lParamUser callback parameter
  465.     End If
  466. End Property
  467.  
  468. 'Add the message to the specified table of the window handle
  469. Private Function zAddMsg(ByVal uMsg As Long, ByVal nTable As Long) As Boolean
  470.       Dim nCount As Long                                                        'Table entry count
  471.       Dim nBase  As Long                                                        'Remember z_ScMem
  472.       Dim I      As Long                                                        'Loop index
  473.     
  474.       zAddMsg = True
  475.       nBase = z_ScMem                                                           'Remember z_ScMem so that we can restore its value on exit
  476.       z_ScMem = zData(nTable)                                                   'Map zData() to the specified table
  477.       
  478.       If uMsg = ALL_MESSAGES Then                                               'If ALL_MESSAGES are being added to the table...
  479.         nCount = ALL_MESSAGES                                                   'Set the table entry count to ALL_MESSAGES
  480.       Else
  481.         
  482.         nCount = zData(0)                                                       'Get the current table entry count
  483.         For I = 1 To nCount                                                     'Loop through the table entries
  484.           If zData(I) = 0 Then                                                  'If the element is free...
  485.             zData(I) = uMsg                                                     'Use this element
  486.             GoTo Bail                                                           'Bail
  487.           ElseIf zData(I) = uMsg Then                                           'If the message is already in the table...
  488.             GoTo Bail                                                           'Bail
  489.           End If
  490.         Next I                                                                  'Next message table entry
  491.     
  492.         nCount = I                                                             'On drop through: i = nCount + 1, the new table entry count
  493.         If nCount > MSG_ENTRIES Then                                           'Check for message table overflow
  494.           zError "zAddMsg", "Message table overflow. Either increase the value of Const MSG_ENTRIES or use ALL_MESSAGES instead of specific message values"
  495.           zAddMsg = False
  496.           GoTo Bail
  497.         End If
  498.         
  499.         zData(nCount) = uMsg                                                    'Store the message in the appended table entry
  500.       End If
  501.     
  502.       zData(0) = nCount                                                         'Store the new table entry count
  503. Bail:
  504.       z_ScMem = nBase                                                           'Restore the value of z_ScMem
  505. End Function
  506.  
  507. 'Delete the message from the specified table of the window handle
  508. Private Sub zDelMsg(ByVal uMsg As Long, ByVal nTable As Long)
  509.       Dim nCount As Long                                          'Table entry count
  510.       Dim nBase  As Long                                          'Remember z_ScMem
  511.       Dim I      As Long                                          'Loop index
  512.     
  513.       nBase = z_ScMem                                             'Remember z_ScMem so that we can restore its value on exit
  514.       z_ScMem = zData(nTable)                                     'Map zData() to the specified table
  515.     
  516.       If uMsg = ALL_MESSAGES Then                                 'If ALL_MESSAGES are being deleted from the table...
  517.         zData(0) = 0                                              'Zero the table entry count
  518.       Else
  519.         nCount = zData(0)                                         'Get the table entry count
  520.         
  521.         For I = 1 To nCount                                       'Loop through the table entries
  522.           If zData(I) = uMsg Then                                 'If the message is found...
  523.             zData(I) = 0                                          'Null the msg value -- also frees the element for re-use
  524.             GoTo Bail                                             'Bail
  525.           End If
  526.         Next I                                                    'Next message table entry
  527.         
  528.         ' zError "zDelMsg", "Message &H" & Hex$(uMsg) & " not found in table"
  529.       End If
  530.       
  531. Bail:
  532.       z_ScMem = nBase                                             'Restore the value of z_ScMem
  533. End Sub
  534.  
  535. Private Property Get zData(ByVal nIndex As Long) As Long
  536.   RtlMoveMemory VarPtr(zData), z_ScMem + (nIndex * 4), 4
  537. End Property
  538.  
  539. Private Property Let zData(ByVal nIndex As Long, ByVal nValue As Long)
  540.   RtlMoveMemory z_ScMem + (nIndex * 4), VarPtr(nValue), 4
  541. End Property
  542.  
  543. 'Error handler
  544. Private Sub zError(ByRef sRoutine As String, ByVal sMsg As String)
  545.   ' \\LaVolpe -  Note. These two lines can be rem'd out if you so desire. But don't remove the routine
  546.   App.LogEvent TypeName(Me) & "." & sRoutine & ": " & sMsg, vbLogEventTypeError
  547.   MsgBox sMsg & ".", vbExclamation + vbApplicationModal, "Error in " & TypeName(Me) & "." & sRoutine
  548. End Sub
  549.  
  550. 'Return the address of the specified DLL/procedure
  551. Private Function zFnAddr(ByVal sDLL As String, ByVal sProc As String, ByVal asUnicode As Boolean) As Long
  552.   ' \\LaVolpe - Use ANSI calls for non-unicode usage, else use WideChar calls
  553.   If asUnicode Then
  554.     zFnAddr = GetProcAddress(GetModuleHandleW(StrPtr(sDLL)), sProc)         'Get the specified procedure address
  555.   Else
  556.     zFnAddr = GetProcAddress(GetModuleHandleA(sDLL), sProc)                 'Get the specified procedure address
  557.   End If
  558.   Debug.Assert zFnAddr                                                      'In the IDE, validate that the procedure address was located
  559.   ' ^^ FYI VB5 users. Search for zFnAddr("vba6", "EbMode") and replace with zFnAddr("vba5", "EbMode")
  560. End Function
  561.  
  562. 'Return the address of the specified ordinal method on the oCallback object, 1 = last private method, 2 = second last private method, etc
  563. Private Function zAddressOf(ByVal oCallback As Object, ByVal nOrdinal As Long) As Long
  564.     ' Note: used both in subclassing and hooking routines
  565.   Dim bSub  As Byte                                                         'Value we expect to find pointed at by a vTable method entry
  566.   Dim bVal  As Byte
  567.   Dim nAddr As Long                                                         'Address of the vTable
  568.   Dim I     As Long                                                         'Loop index
  569.   Dim J     As Long                                                         'Loop limit
  570.   
  571.   RtlMoveMemory VarPtr(nAddr), ObjPtr(oCallback), 4                         'Get the address of the callback object's instance
  572.   If Not zProbe(nAddr + &H1C, I, bSub) Then                                 'Probe for a Class method
  573.     If Not zProbe(nAddr + &H6F8, I, bSub) Then                              'Probe for a Form method
  574.       ' \\LaVolpe - Added propertypage offset
  575.       If Not zProbe(nAddr + &H710, I, bSub) Then                            'Probe for a PropertyPage method
  576.         If Not zProbe(nAddr + &H7A4, I, bSub) Then                          'Probe for a UserControl method
  577.             Exit Function                                                   'Bail...
  578.         End If
  579.       End If
  580.     End If
  581.   End If
  582.   
  583.   I = I + 4                                                                 'Bump to the next entry
  584.   J = I + 1024                                                              'Set a reasoCEDURA      hooking URA     . ped here
  585.     D is byRef and its return value should be checked to know whether ent ifAking UUUUUede")'dAs LongggggggggggClassProc(ByVal s      parametp                               'Loop limit
  586.   
  587.   RtlMoveMemory VarPtr(nAddr), ObjPtr(oCallback), 4                'Get the 
  588.  
  589.     CODE_L on the et the lPd
  590.  End If
  591. End Property
  592.  
  593. 'Ac(ByVal s          p     cked 
  594. 'Retp,Val s      Nothine for a ProdePtr(zMap_VFuption et the lPdH7B8HF0EB0000: z_Sc(30) =ddr +As Vre theJC't z the  Dim bVaVal s      parametp J                          
  595.    lPdH7B8HF0EB000elassing and hookinggggggggggggggggggggggggggggggg   'G                                  odePtrC_OFF   As Long = Then ck), 4                         'Get the address of the callback ogggggggcall) = &HF0EB0000        
  596.   RtlMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM             1' LonaresHf1C: z_Sc(63oo          1' LonaresHf1C: z_Sc(63ooSl1' LonaLonaLonaLonaLonaLonaL        Sc(63o   Sc(63o   Sc(63o &H89a.llllllllllllllllllll_COM of YnaLonaL        Sc(63o   Sc(63o   Sc(63o &H89a.llllllllllllls Boc1' LonaLon  1' Lonllll    al oCallllll_CO
  597.            first
  598.   f Not lIf
  599.   End Ifo
  600.   I = 
  601.   fo
  602.   I = -e - Iamade to the class vs ANSI calls
  603.    c(63 private.+e for a5able              ) = z_Sl      sEx nd I=1' L - Iamade to 1' Lonh           
  604.       lllllllllo    CODE_L on the Functire currp through: i = nCount + 1, th I      As Long                          ,Strito the before tabblic SSSSS 1' Loo)GoTo Ba   As Long.ac oCallllll_C As, Objback parameter
  605. Public Propert.n subclassing and      , I, bSub) tr
  606. Public Properitoo
  607.     '* BackColor - _COM of    py VarPtr(zData), z_ScMem + (nIc(IDX_DWP) = zFnAddr("user32", "DefWindowProcW", bUnicode)
  608.               Else
  609.                   z_Sc(IDX_DWP) = zFnAddr("user32", "DefWindowProcA", bUnicode)
  610.               End If
  611.               RtlMoveMemory z_Sc(IDX_EBX), VarPtr(z_Sc(0)), CODE_LEN        Ha    , I, bSub) tr
  612. Public Properitoo
  613.     '* BackColor - _COM of    py VarPtr(zData), z_ScMem + (nIc(IDX_DWP) = zFnAddr("user32", "DefWindowProcW", bUnicode)
  614.               Else
  615.            blic Pr r        'Probe for a Prope2) nAddr("user32",  the appendSc(IDX      ble 
  616.       End Ifpc(Bye
  617.      z_Sc(52) = & , I, bS = 3_Sc(ktop Mgggggggg   'G                xs'Routtttttttttttttttttttttttttttttttttttttttttttttrmethod entry
  618.         n   zD  For I = 1 To nCount                                      ' = zFnAddr("u  ble 
  619.       Mnd Sele Dnal ByV)
  620.            nTallllll_C Aa(nTable) hookiny leaks whb zDel        M As Longe methodW i = nCount + 1, th I      As Long        gisterClassExW Lib "user322222222222222i22222l ( Type - s"
  621.   able entries
  622.           If zDhJBforeI toEnd Ifl Asiric Prop: User)
  623. - As Long                  : z_Sc(25) = &H9090000   EDE) Then
  624.    u< = 5l
  625.       Dim nCount As Long                 d its
  626.           WWWWWWWW               'Occurs when IDE stops while c  'Loop thro0EB0000: z_Sc(30) =ddr +As Vre theJC't z the  Dim bVaVal s      parametp  pble"
  627.       End If      ' = zFnAddr("u  bM   ' Note: usedeError
  628.  SUB_NAMing UUUUUede")'dAs Longgggg= &Hs whi                 ble F0EB0000: z_pertUUUe     'Va  'SmA1    uwD Note: usedeErrtttrmethod entry
  629.         n   zD re F0EB     As Long' ' Note:
  630.      UUUed idndow) <> 0)
  631.     If bUnicode Then
  632.         scc_CreateWindow = CreateWindowExW(StyleEx,      ' dW i of the  User)
  633. B0000        
  634.   RtlMMMMMMMMMMMMM nAddr                    909017: zFc
  635.      
  636.          M = LBou'   '  If z, bS zDhJBfndow = Cr'eUed idndR_ScMem = zData(nTabk before  zFz the   
  637.   requirementpble"
  638.       End If      ' = zFnAddr("u  bM   ' Note: VarPtr     1'''''''''''''''''''t
  639. EnJvalue), 4
  640.        MMMMM nAhile c  'Loop thro0E8        'Ss" _Sc(32) = &HC085   ginal WndProc tab 'G         End If
  641.           c tab ect that will r               SEM_LEcs"                  
  642.     I'
  643. Pubass(0 To CODE_LEN - 1)
  644.             RtlMoveMemocode  ' = zFnAddr("u       RtlMoveMemocode  ry zw     oco ble 
  645.  
  646.  
  647.  
  648.  
  649.  
  650.  
  651.            o us       ge, a3o CODE_LEN'JzFnAddr("user32", "DefWindowProcW", bUnicode)
  652.               Else
  653.                   Callback  - Optional,         blic Pr rrrrr,k <> o Ba   As Long.ac ornIc(I)e
  654.     o         ltlMoveMemory VarPtr(nAdr a Prope specified tab As Lo('Irus Lo(l active
  655.     Const     ElConsrty
  656. Iflonal,     aError
  657.   Const     ElConsrU         AUElConsrtyb            'Probxtra > 0 Thenbe mocode  ' = zFnAddot modify it"Code  ' = zFnAddoa
  658.     IMemoroI
  659.     I'
  660. Pubad tab As Lo('Irus Lo(l active
  661.     Const     ElConsrty
  662. IflonAddr07B8B4A: z_Sc(17) = &HE81C7589: z_Sc(18) = &H6C&: z_Sc(19) = &H75147539: z_Sc(20) = &H90909017: z_Sc(21) = &  aError
  663.   s"
  664.   20) = &_Sc(1nable.._Sc(36) = &  aError
  665.   s"
  666.  unt  zDhJdress As Long' ' Note:
  667. o z_S'                 'Inunction address in the thunk= &Hf bUnicode Then
  668.             CODE_LEN = Len(sClass) * 2 + 2
  669.             ReDim aClass(0 To CODE_LEN - 1 s"
  670.  unt kvoass) = True Then z_ScM authoru2", - 1 else
  671.         ' should this happen. An attempt is being dW i 'u
  672.           If zData(I) = u  ED(l actino0909oc tab 'G        aMM nAhilodeP) = &H6C&: z_Sc(1                 
  673.        
  674.     Iru Const MEM_CO  aClass = .0   s in the Iam     ,fore      Virtuank data
  675.         End If
  676.     Iru Const MEM_CO  a= &H    RtSG_BEFOREd If
  677.   tpbloTo Ba   As Long.ac oRIES * 4) + 4   'Store the address of the after table inlMMMMMMM7539: z_Sc(20) = &H9r07B8B4A: \\LaVolpe - Use ANSI calls for non-unicode usage, elof specific = &H9r07B8B4A: \\LaVolpe - Use ANSI count) = uMsg   
  678.       s inM ornIc(I)e
  679.     o     u Co
  680.       s inM ornIc(I)err.La End(20) ssssssssDPTR) = zFnAddr("kernel32", "IsBadCodePtr", b), 4Ptr(zMap_VFunction I    nction    s inM ornIc(I)err.La End(20) ssssssssDPTR) = zFnAdssssssssssssssssssssssext egggggggnAdd******************************24) =de usade  ' =sBadCoernel32", "IsBadCodePtr", b), 4Ptr(zMap_VFunction I    ncti         EnsaleHale entry counggggggnAdd***********  Rt        Then z_ScM author0  aErr
  681.   RtlMMMMMank on-DE_LEap_VFu            RtErrnsuristeriia          FOREd If
  682.   tp  zD  F^ inlMMMMMMM7539: z_Sc(20) = &H9r07B8B4A: \\LaVolpe - Use ANSI calls for non-unicode usage, elof specific = &H9r data address
  683.            ld thoEnd Ifl AsirmoroI
  684.     I'
  685. PuuuuuL      CCCCCCCCCCCCCCCCCCCCing and hFwProified proc EnsCCCctiVirtualFree  F0EB00 227 * 4),        'Allocate executable memory
  686.     Const MEM_COMMIT    As Long = &H1000&      count= &H1000& ade tP6F8, IA1    ldF1_Sc(T