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
|
|