VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "RabbitCollection7"
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 collection
Private m_Hutch As Collection

' Add an existing rabbit or create a new one
Public Sub Add(Optional obj As clsRabbit7)
    Dim IndexToRemove As Long
    
    ' If no object was passed, create a new one
    If obj Is Nothing Then
        Set obj = New clsRabbit7
    Else
        If Find(obj) > 0 Then
            RaiseError 0    ' Object exists error
        End If
    End If
    
    m_Hutch.Add obj
    
    ' Set the hutch for the rabbit
    If Not obj.Hutch Is Nothing Then
        ' When object belonging to a hutch is added
        ' to a new hutch, remove it from the other one
        IndexToRemove = obj.Hutch.Find(obj)
        obj.Hutch.Remove IndexToRemove
    End If
    ' And always have the object refer to this hutch
    obj.Hutch = Me
End Sub


Public Property Get Count() As Long
   If Not m_Hutch Is Nothing Then
        Count = m_Hutch.Count
   End If
End Property


Public Property Get Item(IndexKey As Long) As clsRabbit7
Attribute Item.VB_UserMemId = 0
    If IndexKey < 1 Or IndexKey > m_Hutch.Count Then
        RaiseError 1
    End If
    Set Item = m_Hutch(IndexKey)
End Property

' Remove an object from the hutch
Public Sub Remove(IndexKey As Long)
    Dim obj As clsRabbit7
    If IndexKey < 1 Or IndexKey > m_Hutch.Count Then
        RaiseError 1
    End If
    Set obj = m_Hutch(IndexKey)
    ' Remove object from this hutch
    obj.Hutch = Nothing
    m_Hutch.Remove IndexKey
End Sub

' Find the index for an object in the collection
Public Function Find(findobj As clsRabbit7)
    Dim obj As clsRabbit7
    Dim counter&
    For counter = 1 To m_Hutch.Count
        If m_Hutch(counter) Is findobj Then
            Find = counter
            Exit Function
        End If
    Next counter
End Function


' Enable For...Each support
Public Property Get NewEnum() As IUnknown
Attribute NewEnum.VB_UserMemId = -4
Attribute NewEnum.VB_MemberFlags = "40"
    Set NewEnum = m_Hutch.[_NewEnum]
End Property

' Initialize and destruct the internal collection

Private Sub Class_Initialize()
    Set m_Hutch = New Collection
    Debug.Print "Collection created"
End Sub


Private Sub Class_Terminate()
    Set m_Hutch = Nothing
    Debug.Print "Collection destroyed"
End Sub


' Function to obtain a new collection containing
' only white rabbits
Public Function GetWhiteRabbits() As Collection
    Dim col As New Collection
    Dim obj As clsRabbit7
    For Each obj In m_Hutch
        If obj.Color = "White" Then
            col.Add obj
        End If
    Next
    Set GetWhiteRabbits = col
End Function

' Centralized error handling
' 0 = Attempt to add existing object

Public Sub RaiseError(erroffset As Integer)
    Dim e$
    Select Case erroffset
        Case 0
            e$ = "Object already exists in collection"
        Case 1
            e$ = "Invalid collection index"
    End Select
    Err.Raise vbObjectError + 1000 + erroffset, "RabbitCollection7", e$
End Sub
