point.bas

此源码为vb圣经编码

Attribute VB_Name = "modPoints"
'***************************************************************
' (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 m_MM As CompactibleFixedSizeMemoryManager
Private Type PointVTable
    VTable(6) As Long
End Type
Private m_VTable As PointVTable
Private m_pVTable As Long

Private Type StartVTable
    VTable(5) As Long
End Type
Private m_StartVTable As StartVTable
Private m_pStartVTable As Long

Private Type LinkedPoint
    pVTable As Long
    X As Long
    Y As Long
    Next As ILinkedPoint
    cRefs As Long
End Type

Private Type StartingPoint
    pVTable As Long
    Next As IStartingPoint
    First As ILinkedPoint
    Last As ILinkedPoint
    cRefs As Long
End Type

'The structures are the same size, so we use the same
'memory manager to allocate them.
Private Const cPointMemMgrSize As Long = 20
Private Const cPointsPerBlock As Long = 128

Public Function NewPoint( _
  ByVal X As Long, ByVal Y As Long) As ILinkedPoint
Dim Struct As LinkedPoint
Dim ThisPtr As Long
    If m_pVTable = 0 Then
        If m_MM Is Nothing Then
            Set m_MM = VBoost.CreateFixedSizeMemoryManager( _
              cPointMemMgrSize, cPointsPerBlock, True)
            m_MM.CompactOnFree = True
        End If
        With m_VTable
            .VTable(0) = FuncAddr(AddressOf QueryInterface)
            .VTable(1) = FuncAddr(AddressOf AddRef)
            .VTable(2) = FuncAddr(AddressOf Release)
            .VTable(3) = FuncAddr(AddressOf GetX)
            .VTable(4) = FuncAddr(AddressOf GetY)
            .VTable(5) = FuncAddr(AddressOf GetNext)
            .VTable(6) = FuncAddr(AddressOf SetNext)
            m_pVTable = VarPtr(.VTable(0))
        End With
    End If
    ThisPtr = m_MM.Alloc
    With Struct
        .pVTable = m_pVTable
        .X = X
        .Y = Y
        .cRefs = 1
        CopyMemory ByVal ThisPtr, Struct.pVTable, LenB(Struct)
        ZeroMemory Struct.pVTable, LenB(Struct)
        VBoost.Assign NewPoint, ThisPtr
    End With
End Function
Public Function NewStartingPoint( _
  FirstPoint As ILinkedPoint, _
  PrevStart As IStartingPoint) As IStartingPoint
Dim Struct As StartingPoint
Dim ThisPtr As Long
    If m_pStartVTable = 0 Then
        If m_MM Is Nothing Then
            Set m_MM = VBoost.CreateFixedSizeMemoryManager( _
              cPointMemMgrSize, cPointsPerBlock, True)
            m_MM.CompactOnFree = True
        End If
        With m_StartVTable
            .VTable(0) = FuncAddr(AddressOf StartQueryInterface)
            .VTable(1) = FuncAddr(AddressOf StartAddRef)
            .VTable(2) = FuncAddr(AddressOf StartRelease)
            .VTable(3) = FuncAddr(AddressOf StartGetNext)
            .VTable(4) = FuncAddr(AddressOf StartGetFirst)
            .VTable(5) = FuncAddr(AddressOf StartAddPoint)
            m_pStartVTable = VarPtr(.VTable(0))
        End With
    End If
    ThisPtr = m_MM.Alloc
    With Struct
        .pVTable = m_pStartVTable
        Set .Next = PrevStart
        Set .Last = FirstPoint
        Set .First = .Last
        .cRefs = 1
        CopyMemory ByVal ThisPtr, Struct.pVTable, LenB(Struct)
        ZeroMemory Struct.pVTable, LenB(Struct)
        VBoost.Assign NewStartingPoint, ThisPtr
    End With
End Function

'VTable functions for ILinkedPoint
Private Function QueryInterface(This As LinkedPoint, riid As Long, pvObj As Long) As Long
    'This actually never fires because we use only strong types.
    'Assert and fail just in case.
    Debug.Assert False
    pvObj = 0
    QueryInterface = E_NOINTERFACE
End Function
Private Function AddRef(This As LinkedPoint) As Long
    With This
        .cRefs = .cRefs + 1
        AddRef = .cRefs
    End With
End Function
Private Function Release(This As LinkedPoint) As Long
    With This
        .cRefs = .cRefs - 1
        Release = .cRefs
        If .cRefs = 0 Then
            DeleteThis This
        End If
    End With
End Function
'Called by Release to do the dirty work
Private Sub DeleteThis(This As LinkedPoint)
Dim tmp As LinkedPoint
    This = tmp
    m_MM.Free VarPtr(This)
End Sub
Private Function GetX(This As LinkedPoint) As Long
    GetX = This.X
End Function
Private Function GetY(This As LinkedPoint) As Long
    GetY = This.Y
End Function
Private Function GetNext(This As LinkedPoint) As ILinkedPoint
    Set GetNext = This.Next
End Function
Private Sub SetNext(This As LinkedPoint, pNext As ILinkedPoint)
    Set This.Next = pNext
End Sub

'VTable functions for IStartingPoint
Private Function StartQueryInterface(This As StartingPoint, riid As Long, pvObj As Long) As Long
    'This actually never fires because we use only strong types.
    'Assert and fail just in case.
    Debug.Assert False
    pvObj = 0
    StartQueryInterface = E_NOINTERFACE
End Function
Private Function StartAddRef(This As StartingPoint) As Long
    With This
        .cRefs = .cRefs + 1
        StartAddRef = .cRefs
    End With
End Function
Private Function StartRelease(This As StartingPoint) As Long
    With This
        .cRefs = .cRefs - 1
        StartRelease = .cRefs
        If .cRefs = 0 Then
            StartDeleteThis This
        End If
    End With
End Function
'Called by Release to do the dirty work
Private Sub StartDeleteThis(This As StartingPoint)
Dim tmp As StartingPoint
    This = tmp
    m_MM.Free VarPtr(This)
End Sub
Private Function StartGetNext(This As StartingPoint) As IStartingPoint
    Set StartGetNext = This.Next
End Function
Private Function StartGetFirst(This As StartingPoint) As ILinkedPoint
    Set StartGetFirst = This.First
End Function
Private Sub StartAddPoint(This As StartingPoint, pNew As ILinkedPoint)
    With This
        .Last.SetNext pNew
        Set .Last = pNew
    End With
End Sub
Private Function FuncAddr(ByVal pfn As Long) As Long
    FuncAddr = pfn
End Function