vbAccelerator - Contents of code file: Source_VB_modPerPropertyBrowsing.bas
Attribute VB_Name = "modPerPropertyBrowsing"
'////////////////////////////////////////////////////////////
'// Name : modPerPropertyBrowsing.bas
'// Author : Paul R. Wilde
'// Created : 17th November 1998
'/////////////////////////////////////////////////////////////
'// Copyright Paul R. Wilde 1998. All Rights Reserved.
'/////////////////////////////////////////////////////////////
'// Bug reports, suggestions & comments should be emailed to :
'// prw.exponential@dial.pipex.com
'/////////////////////////////////////////////////////////////
'/////////////////////////////////////////////////////////////
'// Custom implementation to make the IPerPropertyBrowsing
'// interface more 'VB Friendly'
'// ReplaceVTableEntry function taken from the book 'Hardcore
'// Visual Basic' by Bruce Mckinney (although I think it was
'// originally written by Mathew Curland for his 'Black Belt
'// Programming' articles in the VBPJ). This book is recommended
'// reading for anyone attempting VTable function address
'// subclassing.
'/////////////////////////////////////////////////////////////
Option Explicit
'private members
Public m_lngObjRefCount As Long
Private m_lpfnOldGetDisplayString As Long
Private m_lpfnOldGetPredefinedStrings As Long
Private m_lpfnOldGetPredefinedValue As Long
'arrays passed to calling interface must be module-level
'to prevent corruption when strings are freed
Private m_strStringsOut() As String
Private m_lngCookiesOut() As Long
'win32 forward declarations
'constants
Public Const S_OK = &H0&
Public Const E_NOTIMPL = &H80004001 '_HRESULT_TYPEDEF_(0x80004001L)
Public Const E_OUTOFMEMORY = &H8007000E '_HRESULT_TYPEDEF_(0x8007000EL)
Public Const E_INVALIDARG = &H80070057 '_HRESULT_TYPEDEF_(0x80070057L)
Public Const E_NOINTERFACE = &H80004002 '_HRESULT_TYPEDEF_(0x80004002L)
Public Const E_POINTER = &H80004003 '_HRESULT_TYPEDEF_(0x80004003L)
Public Const E_HANDLE = &H80070006 '_HRESULT_TYPEDEF_(0x80070006L)
Public Const E_ABORT = &H80004004 '_HRESULT_TYPEDEF_(0x80004004L)
Public Const E_FAIL = &H80004005 '_HRESULT_TYPEDEF_(0x80004005L)
Public Const E_ACCESSDENIED = &H80070005 '_HRESULT_TYPEDEF_(0x80070005L)
Public Const PAGE_EXECUTE_READWRITE& = &H40&
'function prototypes
'OLE32
Public Declare Function CoTaskMemAlloc Lib "OLE32" (ByVal cBytes As Long) As
Long
'OLEAUT32
Public Declare Function SysAllocString Lib "OLEAUT32" (ByVal lpString As Long)
As Long
'KERNEL32
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDest As
Any, lpSource As Any, ByVal nCount As Long)
Public Declare Function VirtualProtect Lib "kernel32" (ByVal lpAddress As Long,
ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As
Long
Public Function IPerPropertyBrowsing_GetDisplayString(ByVal oThis As Object,
ByVal DispID As Long, ByVal lpDisplayName As Long) As Long
'new vtable method for IPerPropertyBrowsing::GetDisplayString
Dim oSource As IPerPropertyBrowsingVB
Dim bNoDefault As Boolean
Dim strDisplayName As String
Dim lpString As Long
'handle all errors so we don't crash caller
On Error GoTo CATCH_EXCEPTION
'validate passed pointer
If VarPtr(lpDisplayName) = 0 Then
IPerPropertyBrowsing_GetDisplayString = E_POINTER
Exit Function
End If
'cast method to source interface
Set oSource = oThis
bNoDefault = oSource.GetDisplayString(DispID, strDisplayName)
'if no param set by user
If Not bNoDefault Then
'return 'unimplemented' so container displays default
IPerPropertyBrowsing_GetDisplayString = E_NOTIMPL
Else
'copy display string to passed ptr (caller should free the memory
allocated)
lpString = SysAllocString(StrPtr(strDisplayName))
CopyMemory ByVal lpDisplayName, lpString, 4
End If
Exit Function
CATCH_EXCEPTION:
'return 'unimplemented' so container displays default
IPerPropertyBrowsing_GetDisplayString = E_NOTIMPL
End Function
Public Function IPerPropertyBrowsing_GetPredefinedStrings(ByVal oThis As
Object, ByVal DispID As Long, pCaStringsOut As CALPOLESTR, pCaCookiesOut As
CADWORD) As Long
'new vtable method for IPerPropertyBrowsing::GetPredefinedStrings
Dim oSource As IPerPropertyBrowsingVB
Dim bNoDefault As Boolean
Dim cElems As Long
Dim pElems As Long
Dim nElemCount As Integer
Dim lpString As Long
'handle all errors so we don't crash caller
On Error GoTo CATCH_EXCEPTION
'validate passed pointers
If VarPtr(pCaStringsOut) = 0 Or VarPtr(pCaCookiesOut) = 0 Then
IPerPropertyBrowsing_GetPredefinedStrings = E_POINTER
Exit Function
End If
'init array to pass
ReDim m_strStringsOut(0) As String
ReDim m_lngCookiesOut(0) As Long
'cast method to source interface
Set oSource = oThis
bNoDefault = oSource.GetPredefinedStrings(DispID, m_strStringsOut,
m_lngCookiesOut)
'if no param set by user
If (Not bNoDefault) Or (UBound(m_strStringsOut) = 0) Then
'return 'unimplemented' so container displays default
IPerPropertyBrowsing_GetPredefinedStrings = E_NOTIMPL
Else
'make sure arrays are even
cElems = UBound(m_strStringsOut)
If Not UBound(m_lngCookiesOut) = cElems Then
ReDim Preserve m_lngCookiesOut(cElems)
End If
'initialise CALPOLESTR struct
pElems = CoTaskMemAlloc(cElems * 4)
pCaStringsOut.cElems = cElems
pCaStringsOut.pElems = pElems
'copy strings to CALPOLESTR struct
For nElemCount = 0 To cElems - 1
'allocate enough memory for the string & a null terminator
'(the caller ie. VB, will release this memory)
lpString = CoTaskMemAlloc(Len(m_strStringsOut(nElemCount)) + 1)
'copy the string to the temp ptr
CopyMemory ByVal lpString, StrPtr(m_strStringsOut(nElemCount)), 4
'copy the temp ptr to the array
CopyMemory ByVal pElems, ByVal lpString, 4
'incr the element count
pElems = pElems + 4
Next nElemCount
'initialise CADWORD struct
pElems = CoTaskMemAlloc(cElems * 4)
pCaCookiesOut.cElems = cElems
pCaCookiesOut.pElems = pElems
'copy dwords to CADWORD struct
For nElemCount = 0 To cElems - 1
CopyMemory ByVal pElems, m_lngCookiesOut(nElemCount), 4
pElems = pElems + 4
Next nElemCount
End If
Exit Function
CATCH_EXCEPTION:
'return 'unimplemented' so container displays default
IPerPropertyBrowsing_GetPredefinedStrings = E_NOTIMPL
End Function
Public Function IPerPropertyBrowsing_GetPredefinedValue(ByVal oThis As Object,
ByVal DispID As Long, ByVal dwCookie As Long, pVarOut As Variant) As Long
'new vtable method for IPerPropertyBrowsing::GetPredefinedValue
Dim oSource As IPerPropertyBrowsingVB
Dim bNoDefault As Boolean
'handle all errors so we don't crash caller
On Error GoTo CATCH_EXCEPTION
'validate passed pointers
If VarPtr(dwCookie) = 0 Or VarPtr(pVarOut) = 0 Then
IPerPropertyBrowsing_GetPredefinedValue = E_POINTER
Exit Function
End If
'cast method to source interface
Set oSource = oThis
bNoDefault = oSource.GetPredefinedValue(DispID, dwCookie, pVarOut)
'if no param set by user
If Not bNoDefault Then
'return 'unimplemented' so container displays default
IPerPropertyBrowsing_GetPredefinedValue = E_NOTIMPL
End If
Exit Function
CATCH_EXCEPTION:
'return 'unimplemented' so container displays default
IPerPropertyBrowsing_GetPredefinedValue = E_NOTIMPL
End Function
Public Sub ReplaceIPerPropertyBrowsing(ByVal pObject As Object)
'replace vtable for IPerPropertyBrowsing interface
Dim oIPerPropertyBrowsing As EXOLETypes.IExPerPropertyBrowsing
'if already done IPerPropertyBrowsing interface then done
If m_lngObjRefCount > 0 Then
m_lngObjRefCount = m_lngObjRefCount + 1
Debug.Print m_lngObjRefCount
Exit Sub
Else
m_lngObjRefCount = 1
End If
'get ref to OLE IPerPropertyBrowsing interface
Set oIPerPropertyBrowsing = pObject
'replace vtable methods with our subclass procs
' Ignore item 1: QueryInterface
' Ignore item 2: AddRef
' Ignore item 3: Release
m_lpfnOldGetDisplayString =
ReplaceVTableEntry(ObjPtr(oIPerPropertyBrowsing), 4, AddressOf
IPerPropertyBrowsing_GetDisplayString) 'GetDisplayString
' Ignore item 5: MapPropertyToPage (the VB implementation works fine)
m_lpfnOldGetPredefinedStrings =
ReplaceVTableEntry(ObjPtr(oIPerPropertyBrowsing), 6, AddressOf
IPerPropertyBrowsing_GetPredefinedStrings) 'GetPredefinedStrings
m_lpfnOldGetPredefinedValue =
ReplaceVTableEntry(ObjPtr(oIPerPropertyBrowsing), 7, AddressOf
IPerPropertyBrowsing_GetPredefinedValue) 'GetPredefinedValue
Debug.Print "Replaced vtable methods"
End Sub
Public Sub RestoreIPerPropertyBrowsing(ByVal lpObject As Long)
'restore vtable for IPerPropertyBrowsing interface
Dim oObject As Object
Dim oIPerPropertyBrowsing As EXOLETypes.IExPerPropertyBrowsing
'if not last ref count then done
If m_lngObjRefCount > 1 Then
m_lngObjRefCount = m_lngObjRefCount - 1
Debug.Print m_lngObjRefCount
Exit Sub
Else
m_lngObjRefCount = 0
End If
'get ref to object from ptr (no AddRef so don't set to nothing !)
CopyMemory oObject, lpObject, 4
'get ref to OLE IPerPropertyBrowsing interface
Set oIPerPropertyBrowsing = oObject
'delete uncounted reference
CopyMemory oObject, 0&, 4
'restore vtable methods with original procs
' Ignore item 1: QueryInterface
' Ignore item 2: AddRef
' Ignore item 3: Release
ReplaceVTableEntry ObjPtr(oIPerPropertyBrowsing), 4,
m_lpfnOldGetDisplayString 'GetDisplayString
' Ignore item 5: MapPropertyToPage (the VB implementation works fine)
ReplaceVTableEntry ObjPtr(oIPerPropertyBrowsing), 6,
m_lpfnOldGetPredefinedStrings 'GetPredefinedStrings
ReplaceVTableEntry ObjPtr(oIPerPropertyBrowsing), 7,
m_lpfnOldGetPredefinedValue 'GetPredefinedValue
Debug.Print "Restored vtable methods"
End Sub
Public Function ReplaceVTableEntry(ByVal oObject As Long, _
ByVal nEntry As Integer, _
ByVal pFunc As Long) As Long
' Put the function address (callback) directly into the object v-table
' oObject - Pointer to object whose v-table will be modified
' nEntry - Index of v-table entry to be modified
' pFunc - Function pointer of new v-table method
Dim pFuncOld As Long, pVTableHead As Long
Dim pFuncTmp As Long, lOldProtect As Long
' Object pointer contains a pointer to v-table--copy it to temporary
CopyMemory pVTableHead, ByVal oObject, 4 ' pVTableHead = *oObject;
' Calculate pointer to specified entry
pFuncTmp = pVTableHead + (nEntry - 1) * 4
' Save address of previous method for return
CopyMemory pFuncOld, ByVal pFuncTmp, 4 ' pFuncOld = *pFuncTmp;
' Ignore if they're already the same
If pFuncOld <> pFunc Then
' Need to change page protection to write to code
VirtualProtect pFuncTmp, 4, PAGE_EXECUTE_READWRITE, lOldProtect
' Write the new function address into the v-table
CopyMemory ByVal pFuncTmp, pFunc, 4 ' *pFuncTmp = pfunc;
' Restore the previous page protection
VirtualProtect pFuncTmp, 4, lOldProtect, lOldProtect 'Optional
End If
'return address of original proc
ReplaceVTableEntry = pFuncOld
End Function
|
|