home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 5_2007-2008.ISO / data / Zips / PrevInstan2079788162007.psc / PrevInstance1.0 / cPrevInstance.cls next >
Text File  |  2007-08-16  |  53KB  |  963 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 = "cPrevInstance"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. '---------------------------------------------------------------------------------------
  15. ' Module    : cPrevInstance
  16. ' DateTime  : 09/08/2007 23:43
  17. ' Author    : Cobein
  18. ' Mail      : cobein27@yahoo.com
  19. ' Purpose   : Previous instance checker, determines if another instance of our application is
  20. '             running, and send the command line parameter to it.
  21. '---------------------------------------------------------------------------------------
  22. ' Private const MY_ENGLISH_SUCKS                         as Boolean = True
  23. '
  24. ' 09/08/2007: First Cut
  25. ' 09/08/2007: Small bug in GetCommand function ,remove last nullchar from the command
  26. ' 12/08/2007: Replaced fileexists function by a modified API call, parser fuction rewritten
  27. Option Explicit
  28.  
  29. '=======================================================================================
  30. ' Self subclass and callback declarations
  31. ' I removed the comments and unused constants (original code txtCodeId=68737)
  32. '=======================================================================================
  33. Private z_IDEflag           As Long         'Flag indicating we are in IDE
  34. Private z_ScMem             As Long         'Thunk base address
  35. Private z_scFunk            As Collection   'hWnd/thunk-address collection
  36. Private z_hkFunk            As Collection   'hook/thunk-address collection
  37. Private z_cbFunk            As Collection   'callback/thunk-address collection
  38. Private Const IDX_INDEX     As Long = 2     'index of the subclassed hWnd OR hook type
  39. Private Const IDX_CALLBACKORDINAL As Long = 22 ' Ubound(callback thunkdata)+1, index of the callback
  40.  
  41. ' Declarations:
  42. Private Declare Sub RtlMoveMemory Lib "kernel32" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
  43. Private Declare Function IsBadCodePtr Lib "kernel32" (ByVal lpfn As Long) As Long
  44. Private Declare Function VirtualAlloc Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
  45. Private Declare Function VirtualFree Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long
  46. Private Declare Function GetModuleHandleA Lib "kernel32" (ByVal lpModuleName As String) As Long
  47. Private Declare Function GetModuleHandleW Lib "kernel32" (ByVal lpModuleName As Long) As Long
  48. Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
  49.  
  50. Private Enum eThunkType
  51.     SubclassThunk = 0
  52.     HookThunk = 1
  53.     CallbackThunk = 2
  54. End Enum
  55.  
  56. '-Selfsub specific declarations----------------------------------------------------------------------------
  57. Private Enum eMsgWhen                                                   'When to callback
  58.     MSG_BEFORE = 1                                                        'Callback before the original WndProc
  59.     MSG_AFTER = 2                                                         'Callback after the original WndProc
  60.     MSG_BEFORE_AFTER = MSG_BEFORE Or MSG_AFTER                            'Callback before and after the original WndProc
  61. End Enum
  62.  
  63. Private Const IDX_WNDPROC   As Long = 9     'Thunk data index of the original WndProc
  64. Private Const IDX_BTABLE    As Long = 11    'Thunk data index of the Before table
  65. Private Const IDX_ATABLE    As Long = 12    'Thunk data index of the After table
  66. Private Const IDX_PARM_USER As Long = 13    'Thunk data index of the User-defined callback parameter data index
  67. Private Const IDX_UNICODE   As Long = 75    'Must be Ubound(subclass thunkdata)+1; index for unicode support
  68. Private Const ALL_MESSAGES  As Long = -1    'All messages callback
  69. Private Const MSG_ENTRIES   As Long = 32    'Number of msg table entries. Set to 1 if using ALL_MESSAGES for all subclassed windows
  70.  
  71. ' \\LaVolpe - Added non-ANSI version API calls
  72. Private Declare Function CallWindowProcA Lib "user32" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  73. Private Declare Function CallWindowProcW Lib "user32" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  74. Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
  75. Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
  76. Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
  77. Private Declare Function IsWindowUnicode Lib "user32.dll" (ByVal hwnd As Long) As Long
  78. Private Declare Function SendMessageA Lib "user32.dll" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
  79. Private Declare Function SendMessageW Lib "user32.dll" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
  80. Private Declare Function SetWindowLongA Lib "user32" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  81. Private Declare Function SetWindowLongW Lib "user32" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  82. '=======================================================================================
  83. ' End self subclass and callback declarations
  84. '=======================================================================================
  85.  
  86. '// File attributes flags
  87. Private Const FILE_ATTRIBUTE_ARCHIVE                        As Long = &H20
  88. Private Const FILE_ATTRIBUTE_DIRECTORY                      As Long = &H10
  89.  
  90. '// Custom message
  91. Private Const CUSTOM_MESSAGE                                As String = "PREV_INSTANCE"
  92.  
  93. '// SHOW WINDOW
  94. Private Const SW_SHOWNORMAL                                 As Long = 1
  95.  
  96. Private Const DELIM                                         As String = """" & " " & """"
  97.  
  98. '// Window creation
  99. Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" ( _
  100.     ByVal dwExStyle As Long, _
  101.     ByVal lpClassName As String, _
  102.     ByVal lpWindowName As String, _
  103.     ByVal dwStyle As Long, _
  104.     ByVal X As Long, _
  105.     ByVal Y As Long, _
  106.     ByVal nWidth As Long, _
  107.     ByVal nHeight As Long, _
  108.     ByVal hWndParent As Long, _
  109.     ByVal hMenu As Long, _
  110.     ByVal hInstance As Long, _
  111.     lpParam As Any) As Long
  112. Private Declare Function DestroyWindow Lib "user32" ( _
  113.     ByVal hwnd As Long) As Long
  114. '// Window Text
  115. Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" ( _
  116.     ByVal hwnd As Long, _
  117.     ByVal lpString As String, _
  118.     ByVal cch As Long) As Long
  119. Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" ( _
  120.     ByVal hwnd As Long) As Long
  121. Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" ( _
  122.     ByVal hwnd As Long, _
  123.     ByVal lpString As String) As Long
  124. '// Window message
  125. Private Declare Function RegisterWindowMessage Lib "user32.dll" Alias "RegisterWindowMessageA" ( _
  126.     ByVal lpString As String) As Long
  127. '// Properties
  128. Private Declare Function GetProp Lib "user32" Alias "GetPropA" ( _
  129.     ByVal hwnd As Long, _
  130.     ByVal lpString As String) As Long
  131. Private Declare Function SetProp Lib "user32" Alias "SetPropA" ( _
  132.     ByVal hwnd As Long, _
  133.     ByVal lpString As String, _
  134.     ByVal hData As Long) As Long
  135. '// Window enumeration
  136. Private Declare Function EnumWindows Lib "user32.dll" ( _
  137.     ByVal lpEnumFunc As Long, _
  138.     ByVal lParam As Long) As Long
  139. '// Message
  140. Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" ( _
  141.     ByVal hwnd As Long, _
  142.     ByVal wMsg As Long, _
  143.     ByVal wParam As Long, _
  144.     lParam As Any) As Long
  145. '// File attributes
  146. Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" ( _
  147.     ByVal lpFileName As String) As Long
  148. '// Show window
  149. Private Declare Function SetForegroundWindow Lib "user32" ( _
  150.     ByVal hwnd As Long) As Long
  151. Private Declare Function ShowWindow Lib "user32" ( _
  152.     ByVal hwnd As Long, _
  153.     ByVal nCmdShow As Long) As Long
  154. '// File existence
  155. Private Declare Function FileExists Lib "kernel32" Alias "GetShortPathNameA" ( _
  156.     ByVal sFile As String, _
  157.     ByVal nu As Any, _
  158.     ByVal nu As Long) As Long
  159. '^^^ Modified API call
  160.  
  161. '// Event
  162. Public Event PrevInstance( _
  163.     ByVal sCommand As String, _
  164.     ByVal bReady As Boolean, _
  165.     ByVal Files As Collection, _
  166.     ByVal Folders As Collection, _
  167.     ByVal Parameters As Collection)
  168.  
  169. '// Member variables
  170. Private c_lhWnd         As Long
  171. Private c_lCM           As Long
  172. Private c_sID           As String
  173. Private c_lPrevInstnce  As Long
  174. Private c_bReady        As Boolean
  175. Private c_cCommandLine  As Collection
  176.  
  177. '---------------------------------------------------------------------------------------
  178. ' Procedure : Class_Initialize
  179. ' Purpose   : Initialize the class
  180. '---------------------------------------------------------------------------------------
  181. Private Sub Class_Initialize()
  182.  
  183.     c_lhWnd = CreateWindowEx(0, "STATIC", vbNullString, _
  184.        0, 0, 0, 0, 0, 0, 0, App.hInstance, 0) 'Create a window to receive the events and data
  185.     
  186.     c_lCM = RegisterWindowMessage(CUSTOM_MESSAGE) 'Register our custom message
  187.     
  188.     If ssc_Subclass(c_lhWnd, , 1) Then    'Subclass the window
  189.         ssc_AddMsg c_lhWnd, c_lCM, MSG_AFTER
  190.     End If
  191.     
  192.     Set c_cCommandLine = New Collection
  193.     
  194.     If Len(Command$) Then
  195.         c_cCommandLine.Add Command$
  196.     End If
  197.     
  198. End Sub
  199. '---------------------------------------------------------------------------------------
  200. ' Procedure : Class_Terminate
  201. ' Purpose   : Clean up
  202. '---------------------------------------------------------------------------------------
  203. Private Sub Class_Terminate()
  204.     ssc_Terminate 'Terminate subclass
  205.     scb_TerminateCallbacks 'Terminate callbacks
  206.     DestroyWindow c_lhWnd 'Destroy window
  207. End Sub
  208.  
  209. Public Function PrevInstance(Optional ByVal sAppID As String, Optional ByVal sCommand As String) As Long
  210.     
  211.     If Not Len(sAppID) Then
  212.         sAppID = App.EXEName & App.Major & App.Minor
  213.     End If
  214.     
  215.     Call SetProp(c_lhWnd, sAppID, c_lhWnd)
  216.     
  217.     c_sID = sAppID
  218.     
  219.     c_lPrevInstnce = 0
  220.     
  221.     EnumWindows scb_SetCallbackAddr(2, 2), 0&
  222.     
  223.     If c_lPrevInstnce = 0 Then Exit Function
  224.     
  225.     If Not Len(sCommand) Then
  226.         sCommand = Command$
  227.     End If
  228.     
  229.     If Len(sCommand) Then
  230.         Call SetWindowText(c_lPrevInstnce, sCommand)
  231.     End If
  232.     
  233.     PostMessage c_lPrevInstnce, c_lCM, 0&, 0&
  234.     
  235.     PrevInstance = c_lPrevInstnce
  236. End Function
  237.  
  238. Public Property Let Ready(ByVal bReady As Boolean)
  239.     c_bReady = bReady
  240.     If c_bReady Then
  241.         Dim vItem As Variant
  242.         For Each vItem In c_cCommandLine
  243.             ParseData CStr(vItem)
  244.         Next
  245.         Set c_cCommandLine = New Collection
  246.     End If
  247. End Property
  248.  
  249. Public Property Get Ready() As Boolean
  250.     Ready = c_bReady
  251. End Property
  252.  
  253. Public Function ShowForm(ByVal frmClient As Form)
  254.     If frmClient.WindowState = vbMinimized Then
  255.         frmClient.WindowState = vbNormal
  256.     End If
  257.     ShowWindow frmClient.hwnd, SW_SHOWNORMAL
  258.     SetForegroundWindow frmClient.hwnd
  259. End Function
  260.  
  261. '---------------------------------------------------------------------------------------
  262. ' Procedure : ParseData
  263. ' Purpose   : Parse command line parameters
  264. '---------------------------------------------------------------------------------------
  265. Private Sub ParseData(ByVal sData As String)
  266.     Dim cFiles As New Collection
  267.     Dim cFolders As New Collection
  268.     Dim cParameters As New Collection
  269.  
  270.     'Check
  271.     If Len(sData) = 0 Then
  272.         RaiseEvent PrevInstance(vbNullString, c_bReady, cFiles, cFolders, cParameters)
  273.         Exit Sub
  274.     End If
  275.     
  276.     Dim vItem As Variant
  277.     Dim vSubItem As Variant
  278.  
  279.     For Each vItem In Split(sData, DELIM)
  280.         vItem = Trim$(Replace(vItem, Chr$(34), vbNullString))
  281.         If Not Len(vItem) = 0 Then
  282.             If Not FileExists(vItem, 0&, 0) = 0 Then
  283.                 If (GetFileAttributes(vItem) And &H10) Then
  284.                     cFolders.Add IIf(Right$(vItem, 1) = Chr$(92), vItem, vItem & Chr$(92)) 'Is a Folder
  285.                 Else
  286.                     cFiles.Add vItem 'Is a File
  287.                 End If
  288.             Else
  289.                 For Each vSubItem In Split(vItem, Chr$(32))
  290.                     vSubItem = Trim$(vSubItem)
  291.                     If Not Len(vSubItem) = 0 Then cParameters.Add vSubItem 'Is a Parameter
  292.                 Next
  293.             End If
  294.         End If
  295.     Next
  296.     
  297.     RaiseEvent PrevInstance(sData, c_bReady, cFiles, cFolders, cParameters)
  298.  
  299. End Sub
  300.  
  301. '-The following routines are exclusively for the ssc_subclass routines----------------------------
  302. Private Function ssc_Subclass(ByVal lng_hWnd As Long, _
  303.        Optional ByVal lParamUser As Long = 0, _
  304.        Optional ByVal nOrdinal As Long = 1, _
  305.        Optional ByVal oCallback As Object = Nothing, _
  306.        Optional ByVal bIdeSafety As Boolean = True, _
  307.        Optional ByVal bUnicode As Boolean = False) As Boolean 'Subclass the specified window handle
  308.  
  309.     '*************************************************************************************************
  310.     '* lng_hWnd   - Handle of the window to subclass
  311.     '* lParamUser - Optional, user-defined callback parameter
  312.     '* nOrdinal   - Optional, ordinal index of the callback procedure. 1 = last private method, 2 = second last private method, etc.
  313.     '* oCallback  - Optional, the object that will receive the callback. If undefined, callbacks are sent to this object's instance
  314.     '* bIdeSafety - Optional, enable/disable IDE safety measures. NB: you should really only disable IDE safety in a UserControl for design-time subclassing
  315.     '* bUnicode - Optional, if True, Unicode API calls will be made to the window vs ANSI calls
  316.     '*************************************************************************************************
  317.     '* cSelfSub - self-subclassing class template
  318.     '* Paul_Caton@hotmail.com
  319.     '* Copyright free, use and abuse as you see fit.
  320.     '*
  321.     '* v1.0 Re-write of the SelfSub/WinSubHook-2 submission to Planet Source Code............ 20060322
  322.     '* v1.1 VirtualAlloc memory to prevent Data Execution Prevention faults on Win64......... 20060324
  323.     '* v1.2 Thunk redesigned to handle unsubclassing and memory release...................... 20060325
  324.     '* v1.3 Data array scrapped in favour of property accessors.............................. 20060405
  325.     '* v1.4 Optional IDE protection added
  326.     '*      User-defined callback parameter added
  327.     '*      All user routines that pass in a hWnd get additional validation
  328.     '*      End removed from zError.......................................................... 20060411
  329.     '* v1.5 Added nOrdinal parameter to ssc_Subclass
  330.     '*      Switched machine-code array from Currency to Long................................ 20060412
  331.     '* v1.6 Added an optional callback target object
  332.     '*      Added an IsBadCodePtr on the callback address in the thunk prior to callback..... 20060413
  333.     '*************************************************************************************************
  334.     ' Subclassing procedure must be declared identical to the one at the end of this class (Sample at Ordinal #1)
  335.  
  336.     ' \\LaVolpe - reworked routine a bit, revised the ASM to allow auto-unsubclass on WM_DESTROY
  337.     Dim z_Sc(0 To IDX_UNICODE) As Long                 'Thunk machine-code initialised here
  338.     Const CODE_LEN      As Long = 4 * IDX_UNICODE      'Thunk length in bytes
  339.     
  340.     Const MEM_LEN       As Long = CODE_LEN + (8 * (MSG_ENTRIES))  'Bytes to allocate per thunk, data + code + msg tables
  341.     Const PAGE_RWX      As Long = &H40&                'Allocate executable memory
  342.     Const MEM_COMMIT    As Long = &H1000&              'Commit allocated memory
  343.     Const MEM_RELEASE   As Long = &H8000&              'Release allocated memory flag
  344.     Const IDX_EBMODE    As Long = 3                    'Thunk data index of the EbMode function address
  345.     Const IDX_CWP       As Long = 4                    'Thunk data index of the CallWindowProc function address
  346.     Const IDX_SWL       As Long = 5                    'Thunk data index of the SetWindowsLong function address
  347.     Const IDX_FREE      As Long = 6                    'Thunk data index of the VirtualFree function address
  348.     Const IDX_BADPTR    As Long = 7                    'Thunk data index of the IsBadCodePtr function address
  349.     Const IDX_OWNER     As Long = 8                    'Thunk data index of the Owner object's vTable address
  350.     Const IDX_CALLBACK  As Long = 10                   'Thunk data index of the callback method address
  351.     Const IDX_EBX       As Long = 16                   'Thunk code patch index of the thunk data
  352.     Const GWL_WNDPROC   As Long = -4                   'SetWindowsLong WndProc index
  353.     Const WNDPROC_OFF   As Long = &H38                 'Thunk offset to the WndProc execution address
  354.     Const SUB_NAME      As String = "ssc_Subclass"     'This routine's name
  355.     
  356.     Dim nAddr         As Long
  357.     Dim nID           As Long
  358.     Dim nMyID         As Long
  359.  
  360.     If IsWindow(lng_hWnd) = 0 Then                      'Ensure the window handle is valid
  361.         zError SUB_NAME, "Invalid window handle"
  362.         Exit Function
  363.     End If
  364.     
  365.     nMyID = GetCurrentProcessId                         'Get this process's ID
  366.     GetWindowThreadProcessId lng_hWnd, nID              'Get the process ID associated with the window handle
  367.     If nID <> nMyID Then                                'Ensure that the window handle doesn't belong to another process
  368.         zError SUB_NAME, "Window handle belongs to another process"
  369.         Exit Function
  370.     End If
  371.       
  372.     If oCallback Is Nothing Then Set oCallback = Me     'If the user hasn't specified the callback owner
  373.     
  374.     nAddr = zAddressOf(oCallback, nOrdinal)             'Get the address of the specified ordinal method
  375.     If nAddr = 0 Then                                   'Ensure that we've found the ordinal method
  376.         zError SUB_NAME, "Callback method not found"
  377.         Exit Function
  378.     End If
  379.         
  380.     z_ScMem = VirtualAlloc(0, MEM_LEN, MEM_COMMIT, PAGE_RWX) 'Allocate executable memory
  381.     
  382.     If z_ScMem <> 0 Then                                  'Ensure the allocation succeeded
  383.   
  384.         If z_scFunk Is Nothing Then Set z_scFunk = New Collection 'If this is the first time through, do the one-time initialization
  385.         On Error GoTo CatchDoubleSub                              'Catch double subclassing
  386.         z_scFunk.Add z_ScMem, "h" & lng_hWnd                    'Add the hWnd/thunk-address to the collection
  387.         On Error GoTo 0
  388.         
  389.         ' \\Tai Chi Minh Ralph Eastwood - fixed bug where the MSG_AFTER was not being honored
  390.         ' \\LaVolpe - modified thunks to allow auto-unsubclassing when WM_DESTROY received
  391.         z_Sc(14) = &HD231C031: z_Sc(15) = &HBBE58960: z_Sc(16) = &H12345678: z_Sc(17) = &HF63103FF: z_Sc(18) = &H750C4339: z_Sc(19) = &H7B8B4A38: z_Sc(20) = &H95E82C: z_Sc(21) = &H7D810000: z_Sc(22) = &H228&: z_Sc(23) = &HC70C7500: z_Sc(24) = &H20443: z_Sc(25) = &H5E90000: z_Sc(26) = &H39000000: z_Sc(27) = &HF751475: z_Sc(28) = &H25E8&: z_Sc(29) = &H8BD23100: z_Sc(30) = &H6CE8307B: z_Sc(31) = &HFF000000: z_Sc(32) = &H10C2610B: z_Sc(33) = &HC53FF00: z_Sc(34) = &H13D&: z_Sc(35) = &H85BE7400: z_Sc(36) = &HE82A74C0: z_Sc(37) = &H2&: z_Sc(38) = &H75FFE5EB: z_Sc(39) = &H2C75FF30: z_Sc(40) = &HFF2875FF: z_Sc(41) = &H73FF2475: z_Sc(42) = &H1053FF24: z_Sc(43) = &H811C4589: z_Sc(44) = &H13B&: z_Sc(45) = &H39727500:
  392.         z_Sc(46) = &H6D740473: z_Sc(47) = &H2473FF58: z_Sc(48) = &HFFFFFC68: z_Sc(49) = &H873FFFF: z_Sc(50) = &H891453FF: z_Sc(51) = &H7589285D: z_Sc(52) = &H3045C72C: z_Sc(53) = &H8000&: z_Sc(54) = &H8920458B: z_Sc(55) = &H4589145D: z_Sc(56) = &HC4816124: z_Sc(57) = &H4&: z_Sc(58) = &H8B1862FF: z_Sc(59) = &H853AE30F: z_Sc(60) = &H810D78C9: z_Sc(61) = &H4C7&: z_Sc(62) = &H28458B00: z_Sc(63) = &H2975AFF2: z_Sc(64) = &H2873FF52: z_Sc(65) = &H5A1C53FF: z_Sc(66) = &H438D1F75: z_Sc(67) = &H144D8D34: z_Sc(68) = &H1C458D50: z_Sc(69) = &HFF3075FF: z_Sc(70) = &H75FF2C75: z_Sc(71) = &H873FF28: z_Sc(72) = &HFF525150: z_Sc(73) = &H53FF2073: z_Sc(74) = &HC328C328
  393.         
  394.         z_Sc(IDX_EBX) = z_ScMem                                                 'Patch the thunk data address
  395.         z_Sc(IDX_INDEX) = lng_hWnd                                               'Store the window handle in the thunk data
  396.         z_Sc(IDX_BTABLE) = z_ScMem + CODE_LEN                                   'Store the address of the before table in the thunk data
  397.         z_Sc(IDX_ATABLE) = z_ScMem + CODE_LEN + ((MSG_ENTRIES + 1) * 4)         'Store the address of the after table in the thunk data
  398.         z_Sc(IDX_OWNER) = ObjPtr(oCallback)                                     'Store the callback owner's object address in the thunk data
  399.         z_Sc(IDX_CALLBACK) = nAddr                                              'Store the callback address in the thunk data
  400.         z_Sc(IDX_PARM_USER) = lParamUser                                        'Store the lParamUser callback parameter in the thunk data
  401.         
  402.         ' \\LaVolpe - validate unicode request & cache unicode usage
  403.         If bUnicode Then bUnicode = (IsWindowUnicode(lng_hWnd) <> 0&)
  404.         z_Sc(IDX_UNICODE) = bUnicode                                            'Store whether the window is using unicode calls or not
  405.         
  406.         ' \\LaVolpe - added extra parameter "bUnicode" to the zFnAddr calls
  407.         z_Sc(IDX_FREE) = zFnAddr("kernel32", "VirtualFree", bUnicode)           'Store the VirtualFree function address in the thunk data
  408.         z_Sc(IDX_BADPTR) = zFnAddr("kernel32", "IsBadCodePtr", bUnicode)        'Store the IsBadCodePtr function address in the thunk data
  409.         
  410.         Debug.Assert zInIDE
  411.         If bIdeSafety = True And z_IDEflag = 1 Then                             'If the user wants IDE protection
  412.             z_Sc(IDX_EBMODE) = zFnAddr("vba6", "EbMode", bUnicode)                'Store the EbMode function address in the thunk data
  413.         End If
  414.     
  415.         ' \\LaVolpe - use ANSI for non-unicode usage, else use WideChar calls
  416.         If bUnicode Then
  417.             z_Sc(IDX_CWP) = zFnAddr("user32", "CallWindowProcW", bUnicode)          'Store CallWindowProc function address in the thunk data
  418.             z_Sc(IDX_SWL) = zFnAddr("user32", "SetWindowLongW", bUnicode)           'Store the SetWindowLong function address in the thunk data
  419.             z_Sc(IDX_UNICODE) = 1
  420.             RtlMoveMemory z_ScMem, VarPtr(z_Sc(0)), CODE_LEN                        'Copy the thunk code/data to the allocated memory
  421.             nAddr = SetWindowLongW(lng_hWnd, GWL_WNDPROC, z_ScMem + WNDPROC_OFF)    'Set the new WndProc, return the address of the original WndProc
  422.         Else
  423.             z_Sc(IDX_CWP) = zFnAddr("user32", "CallWindowProcA", bUnicode)          'Store CallWindowProc function address in the thunk data
  424.             z_Sc(IDX_SWL) = zFnAddr("user32", "SetWindowLongA", bUnicode)           'Store the SetWindowLong function address in the thunk data
  425.             RtlMoveMemory z_ScMem, VarPtr(z_Sc(0)), CODE_LEN                        'Copy the thunk code/data to the allocated memory
  426.             nAddr = SetWindowLongA(lng_hWnd, GWL_WNDPROC, z_ScMem + WNDPROC_OFF)    'Set the new WndProc, return the address of the original WndProc
  427.         End If
  428.         If nAddr = 0 Then                                                           'Ensure the new WndProc was set correctly
  429.             zError SUB_NAME, "SetWindowLong failed, error #" & Err.LastDllError
  430.             GoTo ReleaseMemory
  431.         End If
  432.         'Store the original WndProc address in the thunk data
  433.         RtlMoveMemory z_ScMem + IDX_WNDPROC * 4, VarPtr(nAddr), 4&              ' z_Sc(IDX_WNDPROC) = nAddr
  434.         ssc_Subclass = True                                                     'Indicate success
  435.     Else
  436.         zError SUB_NAME, "VirtualAlloc failed, error: " & Err.LastDllError
  437.     End If
  438.  
  439.     Exit Function                                                             'Exit ssc_Subclass
  440.     
  441. CatchDoubleSub:
  442.     zError SUB_NAME, "Window handle is already subclassed"
  443.       
  444. ReleaseMemory:
  445.     VirtualFree z_ScMem, 0, MEM_RELEASE                                       'ssc_Subclass has failed after memory allocation, so release the memory
  446. End Function
  447.  
  448. 'Terminate all subclassing
  449. Private Sub ssc_Terminate()
  450.     ' can be made public. Releases all subclassing
  451.     ' can be removed and zTerminateThunks can be called directly
  452.     zTerminateThunks SubclassThunk
  453. End Sub
  454.  
  455. 'UnSubclass the specified window handle
  456. Private Sub ssc_UnSubclass(ByVal lng_hWnd As Long)
  457.     ' can be made public. Releases a specific subclass
  458.     ' can be removed and zUnThunk can be called directly
  459.     zUnThunk lng_hWnd, SubclassThunk
  460. End Sub
  461.  
  462. 'Add the message value to the window handle's specified callback table
  463. Private Sub ssc_AddMsg(ByVal lng_hWnd As Long, ByVal uMsg As Long, Optional ByVal When As eMsgWhen = MSG_AFTER)
  464.     ' Note: can be removed if not needed and zAddMsg can be called directly
  465.     If IsBadCodePtr(zMap_VFunction(lng_hWnd, SubclassThunk)) = 0 Then                 'Ensure that the thunk hasn't already released its memory
  466.         If When And MSG_BEFORE Then                                             'If the message is to be added to the before original WndProc table...
  467.             zAddMsg uMsg, IDX_BTABLE                                              'Add the message to the before table
  468.         End If
  469.         If When And MSG_AFTER Then                                              'If message is to be added to the after original WndProc table...
  470.             zAddMsg uMsg, IDX_ATABLE                                              'Add the message to the after table
  471.         End If
  472.     End If
  473. End Sub
  474.  
  475. 'Delete the message value from the window handle's specified callback table
  476. Private Sub ssc_DelMsg(ByVal lng_hWnd As Long, ByVal uMsg As Long, Optional ByVal When As eMsgWhen = MSG_AFTER)
  477.     ' Note: can be removed if not needed and zDelMsg can be called directly
  478.     If IsBadCodePtr(zMap_VFunction(lng_hWnd, SubclassThunk)) = 0 Then                'Ensure that the thunk hasn't already released its memory
  479.         If When And MSG_BEFORE Then                                             'If the message is to be deleted from the before original WndProc table...
  480.             zDelMsg uMsg, IDX_BTABLE                                              'Delete the message from the before table
  481.         End If
  482.         If When And MSG_AFTER Then                                              'If the message is to be deleted from the after original WndProc table...
  483.             zDelMsg uMsg, IDX_ATABLE                                              'Delete the message from the after table
  484.         End If
  485.     End If
  486. End Sub
  487.  
  488. 'Call the original WndProc
  489. Private Function ssc_CallOrigWndProc(ByVal lng_hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  490.     ' Note: can be removed if you do not use this function inside of your window procedure
  491.     If IsBadCodePtr(zMap_VFunction(lng_hWnd, SubclassThunk)) = 0 Then            'Ensure that the thunk hasn't already released its memory
  492.         If zData(IDX_UNICODE) Then
  493.             ssc_CallOrigWndProc = CallWindowProcW(zData(IDX_WNDPROC), lng_hWnd, uMsg, wParam, lParam) 'Call the original WndProc of the passed window handle parameter
  494.         Else
  495.             ssc_CallOrigWndProc = CallWindowProcA(zData(IDX_WNDPROC), lng_hWnd, uMsg, wParam, lParam) 'Call the original WndProc of the passed window handle parameter
  496.         End If
  497.     End If
  498. End Function
  499.  
  500. 'Get the subclasser lParamUser callback parameter
  501. Private Function zGet_lParamUser(ByVal hWnd_Hook_ID As Long, vType As eThunkType) As Long
  502.     'Note: can be removed if you never need to retrieve/update your user-defined paramter. See ssc_Subclass
  503.     If vType <> CallbackThunk Then
  504.         If IsBadCodePtr(zMap_VFunction(hWnd_Hook_ID, vType)) = 0 Then        'Ensure that the thunk hasn't already released its memory
  505.             zGet_lParamUser = zData(IDX_PARM_USER)                                'Get the lParamUser callback parameter
  506.         End If
  507.     End If
  508. End Function
  509.  
  510. 'Let the subclasser lParamUser callback parameter
  511. Private Sub zSet_lParamUser(ByVal hWnd_Hook_ID As Long, vType As eThunkType, newValue As Long)
  512.     'Note: can be removed if you never need to retrieve/update your user-defined paramter. See ssc_Subclass
  513.     If vType <> CallbackThunk Then
  514.         If IsBadCodePtr(zMap_VFunction(hWnd_Hook_ID, vType)) = 0 Then          'Ensure that the thunk hasn't already released its memory
  515.             zData(IDX_PARM_USER) = newValue                                         'Set the lParamUser callback parameter
  516.         End If
  517.     End If
  518. End Sub
  519.  
  520. 'Add the message to the specified table of the window handle
  521. Private Sub zAddMsg(ByVal uMsg As Long, ByVal nTable As Long)
  522.     Dim nCount As Long                                                        'Table entry count
  523.     Dim nBase  As Long                                                        'Remember z_ScMem
  524.     Dim i      As Long                                                        'Loop index
  525.     
  526.     nBase = z_ScMem                                                           'Remember z_ScMem so that we can restore its value on exit
  527.     z_ScMem = zData(nTable)                                                   'Map zData() to the specified table
  528.     
  529.     If uMsg = ALL_MESSAGES Then                                               'If ALL_MESSAGES are being added to the table...
  530.         nCount = ALL_MESSAGES                                                   'Set the table entry count to ALL_MESSAGES
  531.     Else
  532.         nCount = zData(0)                                                       'Get the current table entry count
  533.         If nCount >= MSG_ENTRIES Then                                           'Check for message table overflow
  534.             zError "zAddMsg", "Message table overflow. Either increase the value of Const MSG_ENTRIES or use ALL_MESSAGES instead of specific message values"
  535.             GoTo Bail
  536.         End If
  537.     
  538.         For i = 1 To nCount                                                     'Loop through the table entries
  539.             If zData(i) = 0 Then                                                  'If the element is free...
  540.                 zData(i) = uMsg                                                     'Use this element
  541.                 GoTo Bail                                                           'Bail
  542.             ElseIf zData(i) = uMsg Then                                           'If the message is already in the table...
  543.                 GoTo Bail                                                           'Bail
  544.             End If
  545.         Next i                                                                  'Next message table entry
  546.     
  547.         nCount = i                                                              'On drop through: i = nCount + 1, the new table entry count
  548.         zData(nCount) = uMsg                                                    'Store the message in the appended table entry
  549.     End If
  550.     
  551.     zData(0) = nCount                                                         'Store the new table entry count
  552. Bail:
  553.     z_ScMem = nBase                                                           'Restore the value of z_ScMem
  554. End Sub
  555.  
  556. 'Delete the message from the specified table of the window handle
  557. Private Sub zDelMsg(ByVal uMsg As Long, ByVal nTable As Long)
  558.     Dim nCount As Long                                                        'Table entry count
  559.     Dim nBase  As Long                                                        'Remember z_ScMem
  560.     Dim i      As Long                                                        'Loop index
  561.     
  562.     nBase = z_ScMem                                                           'Remember z_ScMem so that we can restore its value on exit
  563.     z_ScMem = zData(nTable)                                                   'Map zData() to the specified table
  564.     
  565.     If uMsg = ALL_MESSAGES Then                                               'If ALL_MESSAGES are being deleted from the table...
  566.         zData(0) = 0                                                            'Zero the table entry count
  567.     Else
  568.         nCount = zData(0)                                                       'Get the table entry count
  569.         
  570.         For i = 1 To nCount                                                     'Loop through the table entries
  571.             If zData(i) = uMsg Then                                               'If the message is found...
  572.                 zData(i) = 0                                                        'Null the msg value -- also frees the element for re-use
  573.                 GoTo Bail                                                           'Bail
  574.             End If
  575.         Next i                                                                  'Next message table entry
  576.         
  577.         zError "zDelMsg", "Message &H" & Hex$(uMsg) & " not found in table"
  578.     End If
  579.       
  580. Bail:
  581.     z_ScMem = nBase                                                           'Restore the value of z_ScMem
  582. End Sub
  583.  
  584. '-SelfCallback code------------------------------------------------------------------------------------
  585. '-The following routines are exclusively for the scb_SetCallbackAddr routines----------------------------
  586. Private Function scb_SetCallbackAddr(ByVal nParamCount As Long, _
  587.        Optional ByVal nOrdinal As Long = 1, _
  588.        Optional ByVal oCallback As Object = Nothing, _
  589.        Optional ByVal bIdeSafety As Boolean = True) As Long   'Return the address of the specified callback thunk
  590.     '*************************************************************************************************
  591.     '* nParamCount  - The number of parameters that will callback
  592.     '* nOrdinal     - Callback ordinal number, the final private method is ordinal 1, the second last is ordinal 2, etc...
  593.     '* oCallback    - Optional, the object that will receive the callback. If undefined, callbacks are sent to this object's instance
  594.     '* bIdeSafety   - Optional, set to false to disable IDE protection.
  595.     '*************************************************************************************************
  596.     ' Callback procedure must return a Long even if, per MSDN, the callback procedure is a Sub vs Function
  597.     ' The number of parameters are dependent on the individual callback procedures
  598.     
  599.     Const MEM_LEN     As Long = IDX_CALLBACKORDINAL * 4 + 4     'Memory bytes required for the callback thunk
  600.     Const PAGE_RWX    As Long = &H40&                           'Allocate executable memory
  601.     Const MEM_COMMIT  As Long = &H1000&                         'Commit allocated memory
  602.     Const SUB_NAME      As String = "scb_SetCallbackAddr"       'This routine's name
  603.     Const INDX_OWNER    As Long = 0
  604.     Const INDX_CALLBACK As Long = 1
  605.     Const INDX_EBMODE   As Long = 2
  606.     Const INDX_BADPTR   As Long = 3
  607.     Const INDX_EBX      As Long = 5
  608.     Const INDX_PARAMS   As Long = 12
  609.     Const INDX_PARAMLEN As Long = 17
  610.  
  611.     Dim z_Cb()    As Long    'Callback thunk array
  612.     Dim nCallback As Long
  613.       
  614.     If z_cbFunk Is Nothing Then
  615.         Set z_cbFunk = New Collection           'If this is the first time through, do the one-time initialization
  616.     Else
  617.         On Error Resume Next                    'Catch already initialized?
  618.         z_ScMem = z_cbFunk.Item("h" & nOrdinal) 'Test it
  619.         If Err = 0 Then
  620.             scb_SetCallbackAddr = z_ScMem + 16  'we had this one, just reference it
  621.             Exit Function
  622.         End If
  623.         On Error GoTo 0
  624.     End If
  625.     
  626.     If nParamCount < 0 Then                     ' validate parameters
  627.         zError SUB_NAME, "Invalid Parameter count"
  628.         Exit Function
  629.     End If
  630.     
  631.     If oCallback Is Nothing Then Set oCallback = Me     'If the user hasn't specified the callback owner
  632.     nCallback = zAddressOf(oCallback, nOrdinal)         'Get the callback address of the specified ordinal
  633.     If nCallback = 0 Then
  634.         zError SUB_NAME, "Callback address not found."
  635.         Exit Function
  636.     End If
  637.     z_ScMem = VirtualAlloc(0, MEM_LEN, MEM_COMMIT, PAGE_RWX) 'Allocate executable memory
  638.         
  639.     If z_ScMem = 0& Then
  640.         zError SUB_NAME, "VirtualAlloc failed, error: " & Err.LastDllError  ' oops
  641.         Exit Function
  642.     End If
  643.     z_cbFunk.Add z_ScMem, "h" & nOrdinal                  'Add the callback/thunk-address to the collection
  644.         
  645.     ReDim z_Cb(0 To IDX_CALLBACKORDINAL) As Long          'Allocate for the machine-code array
  646.     
  647.     ' Create machine-code array
  648.     z_Cb(4) = &HBB60E089: z_Cb(6) = &H73FFC589: z_Cb(7) = &HC53FF04: z_Cb(8) = &H7B831F75: z_Cb(9) = &H20750008: z_Cb(10) = &HE883E889: z_Cb(11) = &HB9905004: z_Cb(13) = &H74FF06E3: z_Cb(14) = &HFAE2008D: z_Cb(15) = &H53FF33FF: z_Cb(16) = &HC2906104: z_Cb(18) = &H830853FF: z_Cb(19) = &HD87401F8: z_Cb(20) = &H4589C031: z_Cb(21) = &HEAEBFC
  649.     
  650.     z_Cb(INDX_BADPTR) = zFnAddr("kernel32", "IsBadCodePtr", False)
  651.     z_Cb(INDX_OWNER) = ObjPtr(oCallback)                  'Set the Owner
  652.     z_Cb(INDX_CALLBACK) = nCallback                       'Set the callback address
  653.     z_Cb(IDX_CALLBACKORDINAL) = nOrdinal                  'Cache ordinal used for zTerminateThunks
  654.       
  655.     Debug.Assert zInIDE
  656.     If bIdeSafety = True And z_IDEflag = 1 Then             'If the user wants IDE protection
  657.         z_Cb(INDX_EBMODE) = zFnAddr("vba6", "EbMode", False)  'EbMode Address
  658.     End If
  659.         
  660.     z_Cb(INDX_PARAMS) = nParamCount                         'Set the parameter count
  661.     z_Cb(INDX_PARAMLEN) = nParamCount * 4                   'Set the number of stck bytes to release on thunk return
  662.       
  663.     '\\LaVolpe - redirect address to proper location in virtual memory. Was: z_Cb(INDX_EBX) = VarPtr(z_Cb(INDX_OWNER))
  664.     z_Cb(INDX_EBX) = z_ScMem                                'Set the data address relative to virtual memory pointer
  665.       
  666.     RtlMoveMemory z_ScMem, VarPtr(z_Cb(INDX_OWNER)), MEM_LEN 'Copy thunk code to executable memory
  667.     scb_SetCallbackAddr = z_ScMem + 16                       'Thunk code start address
  668.     
  669. End Function
  670.  
  671. Private Sub scb_ReleaseCallback(ByVal nOrdinal As Long)
  672.     ' can be made public. Releases a specific callback
  673.     ' can be removed and zUnThunk can be called directly
  674.     zUnThunk nOrdinal, CallbackThunk
  675. End Sub
  676. Private Sub scb_TerminateCallbacks()
  677.     ' can be made public. Releases all callbacks
  678.     ' can be removed and zTerminateThunks can be called directly
  679.     zTerminateThunks CallbackThunk
  680. End Sub
  681.  
  682.  
  683. '========================================================================
  684. ' COMMON USE ROUTINES
  685. '-The following routines are used for each of the three types of thunks
  686. '========================================================================
  687.  
  688. 'Map zData() to the thunk address for the specified window handle
  689. Private Function zMap_VFunction(ByVal vFuncTarget As Long, vType As eThunkType) As Long
  690.     
  691.     ' vFuncTarget is one of the following, depending on vType
  692.     '   - Subclassing:  the hWnd of the window subclassed
  693.     '   - Hooking:      the hook type created
  694.     '   - Callbacks:    the ordinal of the callback
  695.     
  696.     Dim thunkCol As Collection
  697.     
  698.     If vType = CallbackThunk Then
  699.         Set thunkCol = z_cbFunk
  700.     ElseIf vType = HookThunk Then
  701.         Set thunkCol = z_hkFunk
  702.     ElseIf vType = SubclassThunk Then
  703.         Set thunkCol = z_scFunk
  704.     Else
  705.         zError "zMap_Vfunction", "Invalid thunk type passed"
  706.         Exit Function
  707.     End If
  708.     
  709.     If thunkCol Is Nothing Then
  710.         zError "zMap_VFunction", "Thunk hasn't been initialized"
  711.     Else
  712.         On Error GoTo Catch
  713.         z_ScMem = thunkCol("h" & vFuncTarget)                    'Get the thunk address
  714.         zMap_VFunction = z_ScMem
  715.     End If
  716.     Exit Function                                               'Exit returning the thunk address
  717.     
  718. Catch:
  719.     zError "zMap_VFunction", "Thunk type for ID of " & vFuncTarget & " does not exist"
  720. End Function
  721.  
  722. 'Error handler
  723. Private Sub zError(ByVal sRoutine As String, ByVal sMsg As String)
  724.     ' \\LaVolpe -  Note. These two lines can be rem'd out if you so desire. But don't remove the routine
  725.     App.LogEvent TypeName(Me) & "." & sRoutine & ": " & sMsg, vbLogEventTypeError
  726.     MsgBox sMsg & ".", vbExclamation + vbApplicationModal, "Error in " & TypeName(Me) & "." & sRoutine
  727. End Sub
  728.  
  729. 'Return the address of the specified DLL/procedure
  730. Private Function zFnAddr(ByVal sDLL As String, ByVal sProc As String, ByVal asUnicode As Boolean) As Long
  731.     If asUnicode Then
  732.         zFnAddr = GetProcAddress(GetModuleHandleW(StrPtr(sDLL)), sProc)         'Get the specified procedure address
  733.     Else
  734.         zFnAddr = GetProcAddress(GetModuleHandleA(sDLL), sProc)                 'Get the specified procedure address
  735.     End If
  736.     Debug.Assert zFnAddr                                                      'In the IDE, validate that the procedure address was located
  737.     ' ^^ FYI VB5 users. Search for zFnAddr("vba6", "EbMode") and replace with zFnAddr("vba5", "EbMode")
  738. End Function
  739.  
  740. 'Return the address of the specified ordinal method on the oCallback object, 1 = last private method, 2 = second last private method, etc
  741. Private Function zAddressOf(ByVal oCallback As Object, ByVal nOrdinal As Long) As Long
  742.     ' Note: used both in subclassing and hooking routines
  743.     Dim bSub  As Byte                                                         'Value we expect to find pointed at by a vTable method entry
  744.     Dim bVal  As Byte
  745.     Dim nAddr As Long                                                         'Address of the vTable
  746.     Dim i     As Long                                                         'Loop index
  747.     Dim j     As Long                                                         'Loop limit
  748.   
  749.     RtlMoveMemory VarPtr(nAddr), ObjPtr(oCallback), 4                         'Get the address of the callback object's instance
  750.     If Not zProbe(nAddr + &H1C, i, bSub) Then                                 'Probe for a Class method
  751.         If Not zProbe(nAddr + &H6F8, i, bSub) Then                              'Probe for a Form method
  752.             ' \\LaVolpe - Added propertypage offset
  753.             If Not zProbe(nAddr + &H710, i, bSub) Then                            'Probe for a PropertyPage method
  754.                 If Not zProbe(nAddr + &H7A4, i, bSub) Then                          'Probe for a UserControl method
  755.                     Exit Function                                                   'Bail...
  756.                 End If
  757.             End If
  758.         End If
  759.     End If
  760.   
  761.     i = i + 4                                                                 'Bump to the next entry
  762.     j = i + 1024                                                              'Set a reasonable limit, scan 256 vTable entries
  763.     Do While i < j
  764.         RtlMoveMemory VarPtr(nAddr), i, 4                                       'Get the address stored in this vTable entry
  765.     
  766.         If IsBadCodePtr(nAddr) Then                                             'Is the entry an invalid code address?
  767.             RtlMoveMemory VarPtr(zAddressOf), i - (nOrdinal * 4), 4               'Return the specified vTable entry address
  768.             Exit Do                                                               'Bad method signature, quit loop
  769.         End If
  770.  
  771.         RtlMoveMemory VarPtr(bVal), nAddr, 1                                    'Get the byte pointed to by the vTable entry
  772.         If bVal <> bSub Then                                                    'If the byte doesn't match the expected value...
  773.             RtlMoveMemory VarPtr(zAddressOf), i - (nOrdinal * 4), 4               'Return the specified vTable entry address
  774.             Exit Do                                                               'Bad method signature, quit loop
  775.         End If
  776.     
  777.         i = i + 4                                                               'Next vTable entry
  778.     Loop
  779. End Function
  780.  
  781. 'Probe at the specified start address for a method signature
  782. Private Function zProbe(ByVal nStart As Long, ByRef nMethod As Long, ByRef bSub As Byte) As Boolean
  783.     Dim bVal    As Byte
  784.     Dim nAddr   As Long
  785.     Dim nLimit  As Long
  786.     Dim nEntry  As Long
  787.   
  788.     nAddr = nStart                                                            'Start address
  789.     nLimit = nAddr + 32                                                       'Probe eight entries
  790.     Do While nAddr < nLimit                                                   'While we've not reached our probe depth
  791.         RtlMoveMemory VarPtr(nEntry), nAddr, 4                                  'Get the vTable entry
  792.     
  793.         If nEntry <> 0 Then                                                     'If not an implemented interface
  794.             RtlMoveMemory VarPtr(bVal), nEntry, 1                                 'Get the value pointed at by the vTable entry
  795.             If bVal = &H33 Or bVal = &HE9 Then                                    'Check for a native or pcode method signature
  796.                 nMethod = nAddr                                                     'Store the vTable entry
  797.                 bSub = bVal                                                         'Store the found method signature
  798.                 zProbe = True                                                       'Indicate success
  799.                 Exit Do                                                             'Return
  800.             End If
  801.         End If
  802.     
  803.         nAddr = nAddr + 4                                                       'Next vTable entry
  804.     Loop
  805. End Function
  806.  
  807. Private Function zInIDE() As Long
  808.     ' This is only run in IDE; it is never run when compiled
  809.     z_IDEflag = 1
  810.     zInIDE = z_IDEflag
  811. End Function
  812.  
  813. Private Property Get zData(ByVal nIndex As Long) As Long
  814.     ' retrieves stored value from virtual function's memory location
  815.     RtlMoveMemory VarPtr(zData), z_ScMem + (nIndex * 4), 4
  816. End Property
  817.  
  818. Private Property Let zData(ByVal nIndex As Long, ByVal nValue As Long)
  819.     ' sets value in virtual function's memory location
  820.     RtlMoveMemory z_ScMem + (nIndex * 4), VarPtr(nValue), 4
  821. End Property
  822.  
  823. Private Sub zUnThunk(ByVal thunkID As Long, ByVal vType As eThunkType)
  824.     ' Releases a specific subclass, hook or callback
  825.     ' thunkID depends on vType:
  826.     '   - Subclassing:  the hWnd of the window subclassed
  827.     '   - Hooking:      the hook type created
  828.     '   - Callbacks:    the ordinal of the callback
  829.  
  830.     Const IDX_SHUTDOWN  As Long = 1
  831.     Const MEM_RELEASE As Long = &H8000&                                'Release allocated memory flag
  832.     
  833.     If zMap_VFunction(thunkID, vType) Then
  834.         Select Case vType
  835.             Case SubclassThunk
  836.                 If IsBadCodePtr(z_ScMem) = 0 Then       'Ensure that the thunk hasn't already released its memory
  837.                     zData(IDX_SHUTDOWN) = 1             'Set the shutdown indicator
  838.                     zDelMsg ALL_MESSAGES, IDX_BTABLE    'Delete all before messages
  839.                     zDelMsg ALL_MESSAGES, IDX_ATABLE    'Delete all after messages
  840.                     '\\LaVolpe - Force thunks to replace original window procedure handle. Without this, app can crash when a window is subclassed multiple times simultaneously
  841.                     If zData(IDX_UNICODE) Then          'Force window procedure handle to be replaced
  842.                         SendMessageW thunkID, 0&, 0&, ByVal 0&
  843.                     Else
  844.                         SendMessageA thunkID, 0&, 0&, ByVal 0&
  845.                     End If
  846.                 End If
  847.                 z_scFunk.Remove "h" & thunkID           'Remove the specified thunk from the collection
  848.             Case HookThunk
  849.                 If IsBadCodePtr(z_ScMem) = 0 Then       'Ensure that the thunk hasn't already released its memory
  850.                     zData(IDX_SHUTDOWN) = 1             'Set the shutdown indicator
  851.                     zData(IDX_ATABLE) = 0               ' want no more After messages
  852.                     zData(IDX_BTABLE) = 0               ' want no more Before messages
  853.                 End If
  854.                 z_hkFunk.Remove "h" & thunkID           'Remove the specified thunk from the collection
  855.             Case CallbackThunk
  856.                 If IsBadCodePtr(z_ScMem) = 0 Then       'Ensure that the thunk hasn't already released its memory
  857.                     VirtualFree z_ScMem, 0, MEM_RELEASE 'Release allocated memory
  858.                 End If
  859.                 z_cbFunk.Remove "h" & thunkID           'Remove the specified thunk from the collection
  860.         End Select
  861.     End If
  862.  
  863. End Sub
  864.  
  865. Private Sub zTerminateThunks(ByVal vType As eThunkType)
  866.     ' Removes all thunks of a specific type: subclassing, hooking or callbacks
  867.     Dim i As Long
  868.     Dim thunkCol As Collection
  869.     
  870.     Select Case vType
  871.         Case SubclassThunk
  872.             Set thunkCol = z_scFunk
  873.         Case HookThunk
  874.             Set thunkCol = z_hkFunk
  875.         Case CallbackThunk
  876.             Set thunkCol = z_cbFunk
  877.         Case Else
  878.             Exit Sub
  879.     End Select
  880.     
  881.     If Not (thunkCol Is Nothing) Then                 'Ensure that hooking has been started
  882.         With thunkCol
  883.             For i = .Count To 1 Step -1                   'Loop through the collection of hook types in reverse order
  884.                 z_ScMem = .Item(i)                          'Get the thunk address
  885.                 If IsBadCodePtr(z_ScMem) = 0 Then           'Ensure that the thunk hasn't already released its memory
  886.                     Select Case vType
  887.                         Case SubclassThunk
  888.                             zUnThunk zData(IDX_INDEX), SubclassThunk     'Unsubclass
  889.                         Case HookThunk
  890.                             zUnThunk zData(IDX_INDEX), HookThunk             'Unhook
  891.                         Case CallbackThunk
  892.                             zUnThunk zData(IDX_CALLBACKORDINAL), CallbackThunk ' release callback
  893.                     End Select
  894.                 End If
  895.             Next i                                        'Next member of the collection
  896.         End With
  897.         Set thunkCol = Nothing                         'Destroy the hook/thunk-address collection
  898.     End If
  899. End Sub
  900.  
  901. Private Function GetCommand() As String
  902.     Dim sBuff As String
  903.     Dim lLen As Long
  904.     
  905.     lLen = GetWindowTextLength(c_lhWnd) + 1
  906.     sBuff = String(lLen, vbNullChar)
  907.     GetWindowText c_lhWnd, sBuff, lLen
  908.     If Not Len(sBuff) = 0 Then
  909.         sBuff = Left(sBuff, Len(sBuff) - 1)
  910.     End If
  911.     GetCommand = sBuff
  912. End Function
  913.  
  914. ' ordinal #2
  915. Private Function EnumWindowsProc(ByVal hwnd As Long, ByVal lParam As Long) As Long
  916.     If GetProp(hwnd, c_sID) = hwnd Then
  917.         If Not c_lhWnd = hwnd Then
  918.             c_lPrevInstnce = hwnd
  919.             Exit Function
  920.         End If
  921.     End If
  922.     EnumWindowsProc = True
  923. End Function
  924.  
  925. '- ordinal #1
  926. Private Sub WndProc( _
  927.        ByVal bBefore As Boolean, _
  928.        ByRef bHandled As Boolean, _
  929.        ByRef lReturn As Long, _
  930.        ByVal lng_hWnd As Long, _
  931.        ByVal uMsg As Long, _
  932.        ByVal wParam As Long, _
  933.        ByVal lParam As Long, _
  934.        ByRef lParamUser As Long)
  935.     
  936.     If uMsg = c_lCM Then
  937.         Dim sData As String
  938.     
  939.         sData = Trim$(GetCommand) 'Get the parameters passed by the second instance
  940.         Call SetWindowText(c_lhWnd, vbNullString) 'Delete data
  941.         
  942.         If c_bReady Then
  943.             ParseData sData
  944.         Else
  945.             If Not sData = vbNullString Then
  946.                 c_cCommandLine.Add sData
  947.             End If
  948.             
  949.             Dim cTmp As New Collection
  950.             RaiseEvent PrevInstance(vbNullString, False, cTmp, cTmp, cTmp)
  951.         End If
  952.     End If
  953.     
  954. End Sub
  955.  
  956. ' *************************************************************
  957. ' C A U T I O N   C A U T I O N   C A U T I O N   C A U T I O N
  958. ' -------------------------------------------------------------
  959. ' DO NOT ADD ANY OTHER CODE BELOW THE "END SUB" STATEMENT BELOW
  960. '   add this warning banner to the last routine in your class
  961. ' *************************************************************
  962.  
  963.