vbAccelerator - Contents of code file: cIndexCollection2.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "cIndexCollection2"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

'
' cIndexCollection2
'
' Implements a collection intended to be accessed by
' Index using an array.  This fixes the performance
' problems when inserting or removing items from the
' middle of the array by using the CopyMemory to
' shift all the existing items in a similar chunk.
'

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)

Private m_lItem() As Long
Private m_lCount As Long
Private m_lArraySize As Long
Private m_lAllocationSize As Long

Public Property Get AllocationSize() As Long
   AllocationSize = m_lAllocationSize
End Property
Public Property Let AllocationSize(ByVal lAllocationSize As Long)
   m_lAllocationSize = lAllocationSize
End Property

Public Property Get Item(ByVal Index As Long) As Long
   ' Return the item at Index.  Note since this
   ' array does not automatically reduce size we
   ' need to check that index is in bounds:
   If Index > 0 And Index <= m_lCount Then
      Item = m_lItem(Index)
   Else
      ' Subscript out of range
      Err.Raise 9
   End If
End Property
Public Property Let Item(ByVal Index As Long, ByVal Value As Long)
   If Index > 0 And Index <= m_lCount Then
      m_lItem(Index) = Value
   Else
      ' Subscript out of range
      Err.Raise 9
   End If
End Property
Public Sub Add(ByVal Value As Long, Optional ByVal Index As Long = -1)
Dim j As Long
Dim lTemp As Long

   If Index <= 0 Or Index > m_lCount Then
      ' Add to end
      m_lCount = m_lCount + 1
      If m_lCount > m_lArraySize Then
         m_lArraySize = m_lCount
         ReDim Preserve m_lItem(1 To m_lArraySize) As Long
      End If
      m_lItem(m_lCount) = Value
   Else
      lTemp = m_lItem(m_lCount)
      ' Increase array size as required:
      m_lCount = m_lCount + 1
      If m_lCount > m_lArraySize Then
         m_lArraySize = m_lArraySize + m_lAllocationSize
         ReDim Preserve m_lItem(1 To m_lArraySize) As Long
      End If
      ' Shift up from Index to m_lCount-1
      CopyMemory m_lItem(Index + 1), m_lItem(Index), (m_lCount - Index) * 4
      ' Increase array size:
      ' Set item at Index
      m_lItem(Index) = Value
      ' Set last item:
      m_lItem(m_lCount) = lTemp
      
   End If
   
End Sub
Public Sub Remove(Optional ByVal Index As Long = -1)
Dim j As Long
   ' Reduce size:
   If Index <= 0 Or Index >= m_lCount Then
      m_lCount = m_lCount - 1
      If m_lCount < 0 Then
         m_lCount = 0
      End If
   Else
      m_lCount = m_lCount - 1
      If m_lCount > 0 Then
         ' shift down from Index to m_lCount-1
         CopyMemory m_lItem(Index), m_lItem(Index + 1), (m_lCount - Index + 1)
          * 4
      Else
         ' the end
         m_lCount = 0
      End If
   End If
   
End Sub
Public Sub HeapMinimize()
   ' Reduce the array storage size to
   ' match the number of items in it:
   If m_lArraySize > m_lCount Then
      If m_lCount <= 0 Then
         Erase m_lItem
         m_lArraySize = 0
      Else
         ReDim Preserve m_lItem(1 To m_lCount) As Long
         m_lArraySize = m_lCount
      End If
   End If
End Sub
Public Property Get Count() As Long
   ' Number of items in the array:
   Count = m_lCount
End Property
Public Property Get Exists(ByVal Index As Long)
   ' Does the item at Index exist?
   Exists = (Index > 0 And Index <= m_lCount)
End Property
Public Sub Clear()
   ' Clear down the array:
   m_lCount = 0
End Sub

Private Sub Class_Initialize()
   m_lAllocationSize = 1
End Sub