Collection is in general quite good: I shoved something into the nada, assigned the key for convenience and apply to it ... But, let's say, the keys are dynamically generated depending on the content and in advance we are “not sure” (idiocracy) ponapihivat? Here a list of available keys would be useful, which, alas, is not available ...
Not long Google, stumbled upon the next crutches , which are designed in the form of 1.5 class and are listed below. Immediately make a reservation: not ideal, not comprehensively tested, not my moped (schyutka).
So let's start (by offering a prayer to Allah, it’s not buggy anyhow):

  1. Create a Class Module storage of key / value / checkboxes of choices ( 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

  2. Create a Class Module implementation of Map -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

  3. Brazenly we use =)

Something like this ... Your suggestions / wishes / ways of implementing Map -o of such functionality?

Yes, that's what I wanted to ask: is there a possibility of writing a subclass inside the module, so as not to produce entities once again?

  • Hmm, why clsMapItem need a key in clsMapItem ? It seems he is not used nifiga. - VladD
  • It is used as a key store and received via clsMap.GetKeys() (in the form of a collection of all present keys), which was what was obtained from the standard Collection - Arano-kai
  • And, for sure :) Well, the implementation seems to be correct, although, of course, it is strange that Collection does not give a list of keys. - VladD pm
  • one
    For efficiency, it would be possible to keep a list of all keys separately so as not to recreate it each time. Then, however, this list will have to be updated each time the element is added / removed, which will lead to a loss of performance, so it may be better to leave it as it is. --- And in the elephant killer, are you sure that you are not killing only a copy of the link? In .NET, the foreach loop variable is local, that is, assignment to it does not change the array. What about VBA? --- And in the beginning Contains do not need Contains = false ? - VladD
  • I’m not sure about the killer, I didn’t really get used to VBA ... Now I’m writing a Koichi using the Map and simultaneously checking for bugs / features =) Initially it was just Set colVault = New Collection , it might be worth returning. ______ Contains by default, accepts False , although ... the creepier code is less guschit XD - Arano-kai

1 answer 1

He also wrote a similar crutch, using a similar approach, though in one class module. First I tried to comment in key places ... But then I scored. I am not a professional programmer, and I know the VBA API so-so, so the code is quite simple. I think it will be so clear.

You need to create a ClassModule (I call it AssocArray.cls ) and insert 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 using this class successfully in quite large scripts for the third year already. So far, there have been no errors and critical sags in performance.

As far as I know, VBA is an object language (in the part that operates on objects and allows you to create classes of limited functionality), but does not implement the complete OOP paradigm, so things like inheritance and subclasses are impossible here.