derived.bas

此源码为vb圣经编码

Attribute VB_Name = "modDerived"
'***************************************************************
' (c) Copyright 2000 Matthew J. Curland
'
' This file is from the CD-ROM accompanying the book:
' Advanced Visual Basic 6: Power Techniques for Everyday Programs
'   Author: Matthew Curland
'   Published by: Addison-Wesley, July 2000
'   ISBN: 0-201-70712-8
'   http://www.PowerVB.com
'***************************************************************
Option Explicit

Private Const cVTableSize As Long = 8
Private Type WrapVTable
    VTable(cVTableSize - 1) As Long
End Type
Private m_VTable As WrapVTable
Private m_pVTable As Long

Private m_FDOverrideMe As FunctionDelegator
Private m_pForwardOverrideMe As ICallLongReturnLong

Public Type BaseOverride
    BD As BlindDelegator
    OverrideMeThunk As PushParamThunk
End Type

Public Sub HookVTable(pBDVTable As Long)
    If m_pVTable = 0 Then
        With m_VTable
            'Duplicate the full vtable
            CopyMemory .VTable(0), ByVal pBDVTable, 4 * cVTableSize
            .VTable(7) = FuncAddr(AddressOf OverrideMe)
            m_pVTable = VarPtr(.VTable(0))
        End With
        Set m_pForwardOverrideMe = InitDelegator(m_FDOverrideMe)
    End If
    pBDVTable = m_pVTable
End Sub
Private Function OverrideMe(This As BaseOverride, retVal As Long) As Long
    retVal = 0
    Debug.Assert This.OverrideMeThunk.pfn 'Set next statement to End Function, or else
    m_FDOverrideMe.pfn = This.OverrideMeThunk.pfn
    OverrideMe = m_pForwardOverrideMe.Call(VarPtr(retVal))
End Function
Public Function Derived_OverrideMe(ByVal This As Derived, retVal As String) As Long
    On Error GoTo Error
    'Jump to friend function in derived class
    retVal = This.Base_OverrideMe
    Exit Function
Error:
    Derived_OverrideMe = MapErrorKeepRich
End Function
Private Function FuncAddr(ByVal pfn As Long) As Long
    FuncAddr = pfn
End Function