Для поддержки перечисления в циклах For each на VB6, класс должен реализовывать интерфейс IEnumVariant. Его метод Next используется операторами For Each для получения следующего элемента перечисления. В случае, когда элементы перечисления закончились, метод должен возвратить 0 иначе 1. В своей реализации я использую псевдообъект* EnumObject, который реализует этот интерфейс и вызывает метод у VB-объекта, чтобы мы могли сами настроить поведение перечисления. Для того чтобы любой класс мог использовать перечислитель, я создал интерфейс IEnumerator с одним методом:| Visual Basic | 1
2
3
4
| Option Explicit
Public Function CallNext(ByVal celt As Long, rgvar As Variant, ByVal pCeltFetched As Long) As Long
End Function |
|
| Visual Basic | 1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
| Option Explicit
Private Declare Function GetMem4 Lib "msvbvm60" (pSrc As Any, pDst As Any) As Long
Private Type IUnknown_ ' VTable IUnknown
lpQueryInterface As Long
lpAddRef As Long
lpRelease As Long
End Type
Private Type IEnumVariant_ ' VTable IEnumVariant
IUnk As IUnknown_
lpNext As Long
lpSkip As Long
lpReset As Long
lpClone As Long
End Type
Public Type EnumObject
lpObjPtr As Long ' Указатель на интерфейс
lpVBObjPtr As IEnumerator ' Указатель на экземпляр VB Объекта, для которого будем вызывать метод
nCount As Long ' Счетчик ссылок
End Type
Private Init As Boolean
Private IUnk As IUnknown_
Private IEnumVariant As IEnumVariant_
' Инициализирует объект - перечислитель
Public Function InitEnumObject(VBObject As IEnumerator) As EnumObject
If Not Init Then Initialize
InitEnumObject.lpObjPtr = VarPtr(IUnk.lpQueryInterface)
Set InitEnumObject.lpVBObjPtr = VBObject
InitEnumObject.nCount = 1
End Function
' Запрос интерфейса
Private Function IUnknown_QueryInterface(ObjPtr As EnumObject, ByVal lpRIID As Long, ppvObject As Long) As Long
ObjPtr.nCount = ObjPtr.nCount + 1
' Запрос интерфейса IEnumVariant
ObjPtr.lpObjPtr = VarPtr(IEnumVariant)
ppvObject = VarPtr(ObjPtr)
End Function
' Освободить ссылку
Private Function IUnknown_Release(ObjPtr As EnumObject) As Long
ObjPtr.nCount = ObjPtr.nCount - 1
End Function
Private Function IEnumVariant_Next(ObjPtr As EnumObject, ByVal celt As Long, rgvar As Variant, ByVal pCeltFetched As Long) As Long
If ObjPtr.lpVBObjPtr.CallNext(celt, rgvar, pCeltFetched) Then
IEnumVariant_Next = 0
Else
IEnumVariant_Next = 1
End If
End Function
' Инициализация
Private Sub Initialize()
IUnk.lpQueryInterface = GetAddr(AddressOf IUnknown_QueryInterface)
IUnk.lpRelease = GetAddr(AddressOf IUnknown_Release)
IEnumVariant.IUnk = IUnk
IEnumVariant.lpNext = GetAddr(AddressOf IEnumVariant_Next)
Init = True
End Sub
Private Function GetAddr(Addr As Long) As Long
GetAddr = Addr
End Function |
|
В качестве "подопытного" я выбрал свой небольшой класс-коллекцию:| Visual Basic | 1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
| Option Explicit
Private Declare Function GetMem4 Lib "msvbvm60" (Src As Any, Dst As Any) As Long
Implements IEnumerator ' Реализуем интерфейс для поддержки перечисления
Private Type tPointer ' Индекс в таблице объектов
Hash As Integer ' Хэш
Index As Integer ' Индекс
End Type
Private Type tElement ' Колонка хэш таблицы
Key As String ' Ключ
Value As Variant ' Значение
Next As tPointer ' Индекс следующего элемента
Prev As tPointer ' Индекс предыдущего элемента
End Type
Private Type tItem ' Строка хэш таблицы
ElementsCount As Long ' Количество коллизий+1
Elements() As tElement ' Элементы
End Type
Private Dat() As tItem ' Список
Private mCount As Long
Private mCompareMethod As VbCompareMethod
Private First As tPointer, Last As tPointer
Private EnumPointer As tPointer
Dim IEO As EnumObject
Public Property Get NewEnum() As IUnknown
IEO = InitEnumObject(Me)
EnumPointer = First
GetMem4 VarPtr(IEO), ByVal NewEnum
End Property
Public Property Get CompareMethod() As VbCompareMethod
CompareMethod = mCompareMethod
End Property
Public Property Let CompareMethod(ByVal Value As VbCompareMethod)
If mCount Then Err.Raise 5: Exit Property ' Только когда элементов нет
mCompareMethod = Value
End Property
Public Sub Add(Key As String, Value As Variant)
Dim pt As tPointer
pt = GetFromKey(Key)
If pt.Index <> -1 Then Err.Raise 457: Exit Sub
pt.Index = Dat(pt.Hash).ElementsCount
ReDim Preserve Dat(pt.Hash).Elements(pt.Index)
Dat(pt.Hash).ElementsCount = pt.Index + 1
If IsObject(Value) Then
Set Dat(pt.Hash).Elements(pt.Index).Value = Value
Else
Dat(pt.Hash).Elements(pt.Index).Value = Value
End If
Dat(pt.Hash).Elements(pt.Index).Key = Key
If Last.Hash >= 0 Then
Dat(Last.Hash).Elements(Last.Index).Next = pt
Dat(pt.Hash).Elements(pt.Index).Prev = Last
Else
Dat(pt.Hash).Elements(pt.Index).Prev.Hash = -1
Dat(pt.Hash).Elements(pt.Index).Prev.Index = -1
First = pt
End If
Dat(pt.Hash).Elements(pt.Index).Next.Hash = -1
Dat(pt.Hash).Elements(pt.Index).Next.Index = -1
Last = pt
mCount = mCount + 1
End Sub
Public Property Get Item(Key As String) As Variant
Dim pt As tPointer
pt = GetFromKey(Key): If pt.Index = -1 Then Err.Raise 5: Exit Property
If IsObject(Dat(pt.Hash).Elements(pt.Index).Value) Then
Set Item = Dat(pt.Hash).Elements(pt.Index).Value
Else
Item = Dat(pt.Hash).Elements(pt.Index).Value
End If
End Property
Public Property Let Item(Key As String, Value As Variant)
Dim pt As tPointer
pt = GetFromKey(Key): If pt.Index = -1 Then Err.Raise 5: Exit Property
Dat(pt.Hash).Elements(pt.Index).Value = Value
End Property
Public Property Set Item(Key As String, Value As Variant)
Dim pt As tPointer
pt = GetFromKey(Key): If pt.Index = -1 Then Err.Raise 5: Exit Property
Set Dat(pt.Hash).Elements(pt.Index).Value = Value
End Property
Public Property Get Count() As Long
Count = mCount
End Property
Public Function Exist(Key As String) As Boolean
Exist = GetFromKey(Key).Index <> -1
End Function
Public Sub Remove(Key As String)
Dim pt As tPointer, l As Long, ln As tPointer, lp As tPointer, p As tPointer
pt = GetFromKey(Key): If pt.Index = -1 Then Err.Raise 5: Exit Sub
lp = Dat(pt.Hash).Elements(pt.Index).Prev: ln = Dat(pt.Hash).Elements(pt.Index).Next
For l = pt.Index To Dat(pt.Hash).ElementsCount - 2
Dat(pt.Hash).Elements(l) = Dat(pt.Hash).Elements(l + 1)
' Правим ссылки на элемент
p = Dat(pt.Hash).Elements(l).Prev
If p.Index >= 0 Then Dat(p.Hash).Elements(p.Index).Next.Index = Dat(p.Hash).Elements(p.Index).Next.Index - 1
p = Dat(pt.Hash).Elements(l).Next
If p.Index >= 0 Then Dat(p.Hash).Elements(p.Index).Prev.Index = Dat(p.Hash).Elements(p.Index).Prev.Index - 1
Next
l = Dat(pt.Hash).ElementsCount - 1: Dat(pt.Hash).ElementsCount = l
If l Then
ReDim Preserve Dat(pt.Hash).Elements(l - 1)
Else
Erase Dat(pt.Hash).Elements()
End If
' Правим ссылки
If lp.Index >= 0 Then Dat(lp.Hash).Elements(lp.Index).Next = ln
If ln.Index >= 0 Then Dat(ln.Hash).Elements(ln.Index).Prev = lp
If lp.Index = -1 Then First = ln
If ln.Index = -1 Then Last = lp
mCount = mCount - 1
End Sub
Public Sub Clear()
Call Class_Initialize
End Sub
Public Function HashValue(S As String) As Long
Dim i As Long, ch As Integer
For i = 0 To Len(S) - 1
HashValue = (HashValue * 11 + AscW(LCase(Mid$(S, i + 1, 1)))) And &HFFFF&
Next
HashValue = HashValue Mod 999
End Function
Public Function Items() As Variant()
Dim pt As tPointer, i As Long, ret() As Variant
If mCount = 0 Then Exit Function
pt = First: ReDim Items(mCount - 1)
Do
If IsObject(Dat(pt.Hash).Elements(pt.Index).Value) Then
Set Items(i) = Dat(pt.Hash).Elements(pt.Index).Value
Else
Items(i) = Dat(pt.Hash).Elements(pt.Index).Value
End If
pt = Dat(pt.Hash).Elements(pt.Index).Next
i = i + 1
Loop While i < mCount
End Function
Public Function Keys() As String()
Dim pt As tPointer, i As Long, ret() As String
If mCount = 0 Then Exit Function
pt = First: ReDim ret(mCount - 1)
Do
ret(i) = Dat(pt.Hash).Elements(pt.Index).Key
pt = Dat(pt.Hash).Elements(pt.Index).Next
i = i + 1
Loop While i < mCount
Keys = ret
End Function
Private Function GetFromKey(K As String) As tPointer
Dim i As Long, h As Long
h = HashValue(K): GetFromKey.Hash = h
For i = 0 To Dat(h).ElementsCount - 1
If StrComp(Dat(h).Elements(i).Key, K, mCompareMethod) = 0 Then GetFromKey.Index = i: Exit Function
Next
GetFromKey.Index = -1
End Function
Private Sub Class_Initialize()
ReDim Dat(998): First.Hash = -1: First.Index = -1: Last.Hash = -1: Last.Index = -1
End Sub
Private Sub Class_Terminate()
Erase Dat()
End Sub
' Вызывается при каждой итерации For each
Private Function IEnumerator_CallNext(ByVal celt As Long, rgvar As Variant, ByVal pCeltFetched As Long) As Long
If EnumPointer.Hash = -1 Then Exit Function
If IsObject(Dat(EnumPointer.Hash).Elements(EnumPointer.Index).Value) Then
Set rgvar = Dat(EnumPointer.Hash).Elements(EnumPointer.Index).Value
Else
rgvar = Dat(EnumPointer.Hash).Elements(EnumPointer.Index).Value
End If
EnumPointer = Dat(EnumPointer.Hash).Elements(EnumPointer.Index).Next
IEnumerator_CallNext = True
End Function |
|
Ну и конечно сам тест:| Visual Basic | 1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
| Option Explicit
Private Sub Form_Load()
Dim Col As clsMyCollection, Itm As Variant, i As Long
Set Col = New clsMyCollection
' Добавление в коллекцию
For i = 0 To 999
Col.Add Format$(i, "Ke\y0"), Format$(i, "ite\m_000")
Next
' Удаление элементов
For i = 200 To 800
Col.Remove Format$(i, "Ke\y0")
Next
' Перечисление
For Each Itm In Col
Debug.Print Itm
Next
End Sub |
|
|
