Форум программистов, компьютерный форум, киберфорум
The trick
Войти
Регистрация
Восстановить пароль
Оценить эту запись

Поддержка For Each в VB классах.

Запись от The trick размещена 18.02.2014 в 19:24

Для поддержки перечисления в циклах 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
При вызове этого метода класс, наследующий этот интерфейс, должен передать в качестве rgvar следующий элемент списка и возвратить ненулевое значение, если элементов больше нет, то нужно возвратить нулевое значение, rgvar в этом случае значения не имеет (цикл завершится). Псевдообъект имеет свойство lpVBObjPtr c VB-объектом реализующим интерфейс IEnumerator и вызывающим его метод CallNext. Изначально я хотел сделать все в одном классе с помощью ассемблерных вставок, но потом решил сделать все на VB, поэтому пришлось добавить модуль:
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
Здесь размещен код реализации и поддержки псевдообъектом интерфейса IEnumVariant. Т.к. в VB вроде бы как не используются другие методы интерфейса IEnumVariant я не делал их реализацию. Также не реализован метод AddRef, т.к. он и не нужен в данном коде. Вообще код можно было написать гораздо проще и красивее использовав TLB, но я хотел изучить как все это работает изнутри, поэтому реализация написана на VB полностью. Также здесь не проверяется идентификатор интерфейса, а на любой запрос возвращается IEnumVariant интерфейс, т.к. это не нужно в данном коде.
В качестве "подопытного" я выбрал свой небольшой класс-коллекцию:
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
Как видно из кода, я реализую интерфейс IEnumerator и в запросе интерфейса передаю псевдообъект, также инициализирую указатель на начало связного списка (здесь следовало сделать немного по другому и это действие предоставить перечислителю, т.к. в этой реализации нельзя сделать цикл внутри цикла), при каждом CallNext возвращаю элемент коллекции и перехожу вперед. Здесь можно сделать очень разную реализации, например в зависимости от свойства перечислять по алфавиту или еще как-нибудь.
Ну и конечно сам тест:
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
*В качестве псевдообъект я использую обычный UDT.
Изображения
 
Вложения
Тип файла: rar NewEnum.rar (4.3 Кб, 279 просмотров)
Размещено в Без категории
Показов 4592 Комментарии 0
Всего комментариев 0
Комментарии
 
КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2021, vBulletin Solutions, Inc.