VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "RabbitArray4"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Attribute VB_Ext_KEY = "SavedWithClassBuilder" ,"Yes"
Attribute VB_Ext_KEY = "Collection" ,"clsRabbit3"
Attribute VB_Ext_KEY = "Member0" ,"clsRabbit3"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
' Guide to the Perplexed - Rabbit Test
' Copyright (c) 1997 by Desaware Inc. all Rights Reserved

Option Explicit

'local variable to hold array of rabbit objects
Private m_Hutch() As clsRabbit4
Private m_LastValidEntry As Long
Private m_HutchSize As Long

' Delegate to the collection
Public Sub Add()
    'create a new object
    Dim obj As New clsRabbit4
    ' Make sure array is large enough
    On Error GoTo AddResizeError
    If m_HutchSize = m_LastValidEntry Then
        ' Granularity on additions is arbitrary
        m_HutchSize = m_HutchSize + 4
        ReDim Preserve m_Hutch(m_HutchSize)
    End If
    m_LastValidEntry = m_LastValidEntry + 1
    Set m_Hutch(m_LastValidEntry) = obj
    Exit Sub
AddResizeError:
    ' Raise a memory allocation error here
End Sub



Public Property Get Count() As Long
    Count = m_LastValidEntry
End Property


Public Property Get Item(IndexKey As Long) As clsRabbit4
Attribute Item.VB_UserMemId = 0
    Set Item = m_Hutch(IndexKey)
End Property

' Removes a rabbit at the specified position
Public Sub Remove(IndexKey As Long)
    Dim counter&
    If IndexKey < 0 Or IndexKey > m_LastValidEntry Then
        ' You would probably want to raise an error here
        Exit Sub
    End If
    For counter = IndexKey To m_LastValidEntry - 1
        Set m_Hutch(counter) = m_Hutch(counter + 1)
    Next counter
    Set m_Hutch(m_LastValidEntry) = Nothing
    m_LastValidEntry = m_LastValidEntry - 1
    ' Shrink the array to avoid accumulating too much space
    If m_LastValidEntry + 4 < m_HutchSize Then
        ReDim Preserve m_Hutch(m_LastValidEntry + 4)
        m_HutchSize = m_LastValidEntry + 4
    End If
    
End Sub


' Initialize and destruct the internal collection

Private Sub Class_Initialize()
End Sub

' Clears all the objects in the array
Private Sub Class_Terminate()
    ReDim m_Hutch(0)
End Sub


' Function to obtain a new collection containing
' only white rabbits
' We'll use a generic collection in this case
' to provide a fair comparison
Public Function GetWhiteRabbits() As Collection
    Dim col As New Collection
    Dim counter&
    For counter = 1 To m_LastValidEntry
        ' Array itself is early bound by definition
        If m_Hutch(counter).Color = "White" Then
            col.Add m_Hutch(counter)
        End If
    Next counter
    
    Set GetWhiteRabbits = col
End Function

' Find a particular rabbit in the collection
Public Function FindRabbit(ByVal RabbitNumber As Long) As clsRabbit4
    Dim counter As Long
    For counter = 1 To m_LastValidEntry
        If m_Hutch(counter).Number = RabbitNumber Then
            Set FindRabbit = m_Hutch(counter)
            Exit Function
        End If
    Next
End Function

' Sell a specified rabbit
Public Function SellRabbit(rabbit As clsRabbit4) As Long
    Dim counter&
    Dim RabbitCount As Long
    For counter = 1 To m_LastValidEntry
        If m_Hutch(counter) Is rabbit Then
            ' The class method does the removal
            Remove counter
            Exit Function
        End If
    Next counter

End Function

