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

Public Type DerivedOverride
    BD As BlindDelegator
End Type

Public Function InitOverride(Struct As DerivedOverride, pDerived As Derived) As IUnknown
Dim pUnk As IUnknown
    If m_pVTable = 0 Then
        With m_VTable
            CopyMemory .VTable(0), ByVal VBoost.BlindFunctionPointer(-1), 4 * cVTableSize
            .VTable(7) = FuncAddr(AddressOf OverrideMe)
            m_pVTable = VarPtr(.VTable(0))
        End With
    End If
    Set pUnk = pDerived
    With Struct.BD
        VBoost.Assign .pOuter, pUnk
        VBoost.Assign .pInner, pDerived
        .cRefs = 1
        .pfnDestroy = FuncAddr(AddressOf DestructDerivedOverride)
        .pVTable = m_pVTable
        VBoost.Assign InitOverride, VarPtr(.pVTable)
    End With
End Function
Private Function DestructDerivedOverride(This As DerivedOverride, pInner As IUnknown, pOuter As IUnknownUnrestricted) As Long
    With VBoost
        .AssignZero pInner
        'Leave pOuter non-NULL so that VBoost can read
        'the return value from the Release call.
        pOuter.AddRef
    End With
End Function
Private Function OverrideMe(This As DerivedOverride, retVal As String) As Long
Dim pDerived As Derived
    'Make sure [out] param is NULL
    VBoost.AssignZero retVal
    
    On Error GoTo Error
    'Jump to friend function in derived class
    VBoost.AssignAddRef pDerived, This.BD.pInner
    retVal = pDerived.Derived_OverrideMe
    Exit Function
Error:
    OverrideMe = MapErrorKeepRich
End Function
Private Function FuncAddr(ByVal pfn As Long) As Long
    FuncAddr = pfn
End Function