Sorry, my English is not good.
Private k_items (65535) As Long
Private l_items (65535) As Long
Private f_items (65535) As Long
Such memory consumption will be more
So I put him into the following
Private k_items (999) As Long
Private l_items (999) As Long
Private f_items (999) As Long
To reduce the number of memory
Ask the following array How to reduce memory consumption.
In addition, I want to how the next into a "Clear All" option.
thank
Option Explicit
Private Declare Sub RtlMoveMemory Lib "kernel32" (ByRef lpDest As Any, ByRef lpSource As Any, ByVal cBytes As Long)
Private k_items(999) As Long
Private l_items(999) As Long
Private f_items(999) As Long
Private Items As Object
Private fn As Long
Private ln As Long
Private Sub Class_Initialize()
Dim i As Long
Set Items = CreateObject("Scripting.Dictionary")
For i = 0 To 999
f_items(i) = 999 - i
k_items(i) = -1
Next
fn = 1000
End Sub
Private Sub Class_Terminate()
Set Items = Nothing
End Sub
Public Function Add(Obj As Object) As Boolean
Dim i As Long
If ln = 1000 Then
Add = False
Exit Function
End If
fn = fn - 1
l_items(ln) = f_items(fn)
k_items(f_items(fn)) = ln
Items.Add f_items(fn), Obj
ln = ln + 1
Add = True
End Function
Public Sub Remove(ByVal index As Long)
Dim i As Long
If Not (index >= 0 And index <= ln - 1) Then Exit Sub
f_items(fn) = l_items(index)
fn = fn + 1
k_items(l_items(index)) = -1
Items.Remove l_items(index)
If index < ln - 1 Then
For i = index + 1 To ln - 1
k_items(l_items(i)) = k_items(l_items(i)) - 1
Next
RtlMoveMemory l_items(index), l_items(index + 1), (ln - (index + 1)) * 4
End If
ln = ln - 1
End Sub
Public Property Get Item(ByVal index As Long) As clsItem
If Not (index >= 0 And index <= ln - 1) Then Exit Property
Set Item = Items.Item(l_items(index))
End Property
Public Property Get keyByIndex(ByVal index As Long) As Long
If index >= 0 And index <= ln - 1 Then
keyByIndex = l_items(index)
Else
keyByIndex = -1
End If
End Property
Public Property Get indexByKey(ByVal Key As Long) As Long
If Key >= 0 And Key <= 999 Then
indexByKey = k_items(Key)
Else
indexByKey = -1
End If
End Property
Public Property Get itemByKey(ByVal Key As Long) As clsItem
On Error GoTo 1:
Set itemByKey = Items.Item(Key)
1:
End Property
Public Property Get Count() As Long
Count = ln
End Property
Public Sub Exchange(ByVal i As Long, ByVal j As Long)
Dim temp As Long
temp = l_items(i)
k_items(temp) = j
k_items(l_items(j)) = i
l_items(i) = l_items(j)
l_items(j) = temp
End Sub
Public Sub Sort(ByVal key1 As Long, ByVal key2 As Long)
Dim i As Long
Dim index1 As Long
Dim index2 As Long
If key1 >= 0 And key1 <= 999 Then index1 = k_items(key1) Else index1 = -1
If key2 >= 0 And key2 <= 999 Then index2 = k_items(key2) Else index2 = -1
If (index1 >= 0 And index1 <= ln - 1) And _
(index2 >= 0 And index2 <= ln - 1) And _
index1 <> index2 Then
If index1 > index2 Then
For i = index2 To index1 - 1
k_items(l_items(i)) = k_items(l_items(i)) + 1
Next
i = l_items(index1)
k_items(i) = index2
RtlMoveMemory l_items(index2 + 1), l_items(index2), (index1 - index2) * 4
l_items(index2) = i
Else
For i = index1 + 1 To index2
k_items(l_items(i)) = k_items(l_items(i)) - 1
Next
i = l_items(index1)
k_items(i) = index2
RtlMoveMemory l_items(index1), l_items(index1 + 1), (index2 - index1) * 4
l_items(index2) = i
End If
End If
End Sub
