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