Question:
Collection, in general, is quite good: stuffed something, assigned a key for convenience and use it … But, let's say, our keys are dynamically generated depending on the content and in advance we "not sure" (© Idiocracy), go there stuffed? This is where the list of available keys would come in handy, which, alas, is not available …
After a short google, I came across another crutches , which are designed in the form of class 1.5 and are listed below. I’ll make a reservation right away: it’s not ideal, it hasn’t been comprehensively tested, the moped is not mine (shutka).
So, let's get started (by offering up a prayer to Allah anyhow it was not buggy):
-
Create a
Class Module
storage of pairs of key/value/something to choose from (clsMapItem
):Option Explicit Private key As String 'Собсно ключ, обязательно String' Private value As Variant 'Место для хранения, можно несколько и разных' 'Я использовал Property как более каноничный способ записи геттеров/сеттеров' 'Но принципиального отличия от Sub и Function нет' Public Property Let SetKey(sKey As String) key = sKey End Property Public Property Set SetValue(ByVal vValue As Variant) 'Сеттер для Object' Set value = vValue End Property Public Property Let LetValue(ByVal vValue As Variant) 'Для примитивов' value = vValue End Property Public Property Get GetKey() As String GetKey = key End Property Public Property Get GetObjVal() As Variant 'Геттеры для Obj и прим-ов так же раздельны' Set GetObjVal = value End Property Public Property Get GetPrmVal() As Variant GetPrmVal = value End Property
-
Create a
Class Module
implementation ofMap
-a (clsMap
):Option Explicit Private colVault As Collection 'Хранилище' Private mapItem As clsMapItem 'представитель из п.1' Private Sub Class_Initialize() Set colVault = New Collection 'Создали инстанс? Создаём хранилище' End Sub Private Sub Class_Terminate() Set colVault = Nothing 'Чистим за собой' Set mapItem = Nothing End Sub 'Складовщик переданных няшек' 'Если ключ есть - вынимаем слона и запихиваем жирафа (переписываем значение)' 'Если нету ключа - подключаем новую спарку холодильник/соСлоном' Public Sub Store(k As String, ByVal v As Variant) If (Contains(k)) Then On Error Resume Next 'Так-как тип переданного значения неизвестен' Set mapItem.SetValue = v 'Пробуем оба варианта присвоения' mapItem.LetValue = v 'Один да проскочит обязательно' On Error GoTo 0 'Вот такие вот костыли =)' Else Set mapItem = New clsMapItem mapItem.SetKey = k On Error Resume Next Set mapItem.SetValue = v mapItem.LetValue = v On Error GoTo 0 colVault.add mapItem, k End If End Sub 'Проверятель присутствия ключей' 'Странно, но факт: в VBA7 (Office 2010) функции нет, а по документам есть...' Public Function Contains(k As String) As Boolean Contains = False 'По умолчанию и так False, но мало ли...' On Error GoTo Skip Set mapItem = colVault(k) Contains = True Skip: End Function 'Просто обёртка, нас тут всё устраивает' Public Sub Remove(k As String) colVault.Remove (k) End Sub 'Убиватель слонов. Тоже задокументированная функция-призрак...' Public Sub Clear() Set colVault = New Collection 'Просто новое хранилище. Старое удалит мусорщик при нехватке памяти/по таймеру' End Sub 'И ещё одна обёртка' Public Function Count() As Integer Count = colVault.Count End Function 'Выдаватель ключей' Public Function GetKeys() As Collection Set GetKeys = New Collection For Each mapItem In colVault GetKeys.add (mapItem.GetKey) Next mapItem End Function 'Выдаватель значений' Public Function GetValue(k As String) As Variant Set mapItem = colVault(k) On Error Resume Next 'Здесь костыли идентичны в Store' Set GetValue = mapItem.GetObjVal 'Только с геттерами' GetValue = mapItem.GetPrmVal On Error GoTo 0 End Function
-
Brazenly use =)
Something like this… Your suggestions / wishes / ways to implement Map
-o similar functionality?
Yes, that's what I wanted to ask: is it possible to write a subclass inside the module, so as not to produce entities once again?
Answer:
I also wrote a similar crutch, using a similar approach, though in one class module. At first I tried to comment in key places… But then I gave up. I'm not a professional programmer, and I don't know much about the VBA API, so the code is quite simple. I think it will be clear.
You need to create a ClassModule
(I have it called AssocArray.cls
) and paste the following code:
Private mainarr() As Variant ' главный массив хранения данных
Private count_mainarr As Integer ' длинна словаря
Private Sub Class_Initialize()
count_mainarr = 0
End Sub
Public Sub Add(Key, Value) 'добавление пары Ключ/Значение
If Not KeyIn(Key) Then ' если ключа нет, то добавляется пара полностью
ReDim Preserve mainarr(count_mainarr)
mainarr(count_mainarr) = Array(Key, Value)
count_mainarr = count_mainarr + 1
Else ' если ключ есть, то значение добавляется к существующему
numkey = GetKeyNum(Key)
Dim new_value()
If IsArray(mainarr(numkey)(1)) Then ' если значение по ключу - массив
If IsArray(Value) Then ' если переданное значение так же массив
If IsObject(mainarr(numkey)(1)) Then
Set old_value = mainarr(numkey)(1)
Else
old_value = mainarr(numkey)(1)
End If
newcount = UBound(old_value) + UBound(Value) - LBound(old_value) - LBound(Value) ' вычисление нового значения длинны словаря
ReDim new_value(newcount)
step = 0
For i = LBound(old_value) To UBound(old_value)
If IsObject(old_value(i)) Then
Set new_value(step) = old_value(i)
Else
new_value(step) = old_value(i)
End If
step = step + 1
Next i
For i = LBound(Value) To UBound(Value)
If IsObject(Value(i)) Then
Set new_value(step) = Value(i)
Else
new_value(step) = Value(i)
End If
step = step + 1
Next i
mainarr(numkey)(1) = new_value
Else
If IsObject(mainarr(numkey)(1)) Then
Set old_value = mainarr(numkey)(1)
Else
old_value = mainarr(numkey)(1)
End If
newcount = UBound(old_value) - LBound(old_value) + 1
ReDim new_value(newcount)
For i = 0 To newcount - 1
If IsObject(old_value(i)) Then
Set new_value(i) = old_value(i)
Else
new_value(i) = old_value(i)
End If
Next i
If IsObject(Value) Then
Set new_value(newcount) = Value
Else
new_value(newcount) = Value
End If
mainarr(numkey)(1) = new_value
End If
Else
If IsArray(Value) Then
If IsObject(mainarr(numkey)(1)) Then
Set old_value = mainarr(numkey)(1)
Else
old_value = mainarr(numkey)(1)
End If
ReDim new_value(0)
If IsObject(old_value) Then
Set new_value(0) = old_value
Else
new_value(0) = old_value
End If
d = LBound(Value) - 1
For i = 1 To (UBound(Value) + 1 - LBound(Value))
ReDim Preserve new_value(i)
If IsObject(Value(i + d)) Then
Set new_value(i) = Value(i + d)
Else
new_value(i) = Value(i + d)
End If
Next i
mainarr(numkey)(1) = new_value
Else
If IsObject(Value) Then
Set old_value = mainarr(numkey)(1)
Else
old_value = mainarr(numkey)(1)
End If
ReDim new_value(1)
If IsObject(old_value) Then
Set new_value(0) = old_value
Else
new_value(0) = old_value
End If
If IsObject(Value) Then
Set new_value(1) = Value
Else
new_value(1) = Value
End If
mainarr(numkey)(1) = new_value
End If
End If
End If
End Sub
Public Function GetValue(Key)
If KeyIn(Key) Then
If IsObject(mainarr(GetKeyNum(Key))(1)) Then
Set GetValue = mainarr(GetKeyNum(Key))(1)
Else
GetValue = mainarr(GetKeyNum(Key))(1)
End If
Else
MsgBox "Ключ `" & Key & "` в словаре не обнаружен!"
End If
End Function
Public Function GetKeys()
Dim res(), res_count As Integer
If count_mainarr > 0 Then
For i = LBound(mainarr) To UBound(mainarr)
ReDim Preserve res(res_count)
res(res_count) = mainarr(i)(0)
res_count = res_count + 1
Next i
End If
GetKeys = res
End Function
Public Function KeyIn(Key) As Boolean
KeyIn = False
If count_mainarr > 0 Then
For Each k In GetKeys()
If k = Key Then
KeyIn = True
Exit Function
End If
Next k
End If
End Function
Public Function GetKeyNum(Key) As Integer
Dim num As Integer
GetKeyNum = -1
If count_mainarr > 0 Then
num = LBound(mainarr)
For Each k In GetKeys()
If k = Key Then
GetKeyNum = num
Exit Function
End If
num = num + 1
Next k
End If
End Function
Property Get Count() As Integer
Count = count_mainarr
End Property
Property Get TypeObj() As String
TypeObj = "AssocArray"
End Property
I have been successfully using this class in fairly large scripts for the third year already. So far, no errors and critical sagging in performance have been noticed.
As far as I know, VBA is an object language (to the extent that it operates with objects and allows you to create classes of limited functionality), but does not implement the full OOP paradigm, so things like inheritance and sub-classes are impossible here.