vbAccelerator - Contents of code file: Source_VB_CPerPropertyBrowsing.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CPerPropertyBrowsing"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
'////////////////////////////////////////////////////////////
'// Name : CPerPropertyBrowsing.cls
'// 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
'/////////////////////////////////////////////////////////////

Option Explicit

'private members
Private m_lpUserControl As Long

Public Function GetDispID(MethodName As String) As Long
'get method name from IDispatch interface of UserControl

    Dim oObject As Object
    Dim oIDispatch As EXOLETypes.IExDispatch
    Dim IID_Null As CLSID
    Dim DispID As Long
    
    'get ref to object from ptr (no AddRef so don't set to nothing !)
    CopyMemory oObject, m_lpUserControl, 4
    
    'get ref to OLE IDispatch interface
    Set oIDispatch = oObject
    
    'delete uncounted reference
    CopyMemory oObject, 0&, 4
    
    'get DispatchID for method from IDispatch interface
    '(VB will throw an 'Object Doesn't Support Property Or Method' error on
     failure)
    oIDispatch.GetIDsOfNames IID_Null, StrConv(MethodName, vbUnicode), 1, 0&,
     DispID
    
    'return DispID
    GetDispID = DispID
End Function
Public Sub Attach(UserControl As Object)
'start vtable subclassing

    Dim oIPPB As IPerPropertyBrowsingVB
    Dim oOLEIPPB As EXOLETypes.IExPerPropertyBrowsing
    
    'make sure we haven't already Attached this object
    If m_lpUserControl <> 0 Then
        Err.Raise 50000 + vbObjectError, , "Control has already initialised
         IPerPropertyBrowsing interface."
        Exit Sub
        
    End If
    
    'make sure control implements our IPerPropertyBrowsing interface
    '(VB will throw a 'Type Mismatch' error if it doesn't)
    Set oIPPB = UserControl

    'get ref to OLE IPerPropertyBrowsing interface
    Set oOLEIPPB = UserControl
        
    'replace interface's vtable procs with our own
    ReplaceIPerPropertyBrowsing UserControl
    
    'store object ptr
    m_lpUserControl = ObjPtr(UserControl)
End Sub
Public Sub Detach()
'stop vtable subclassing
    
    'make sure we've initialised this object
    If m_lpUserControl = 0 Then
        Err.Raise 50000 + vbObjectError, , "Control has not initialised
         IPerPropertyBrowsing interface."
        Exit Sub
        
    End If
    
    'restore interface's vtable procs
    RestoreIPerPropertyBrowsing m_lpUserControl
    
    'reset objptr
    m_lpUserControl = 0
End Sub
Private Sub Class_Terminate()

    'handle all errors so we don't bring down the calling app
    On Error Resume Next
    
    'make sure object gets destroyed
    If m_lpUserControl <> 0 Then
        Detach
        
    End If
End Sub