excel – Getting a list of keys from a Collection or how to invent a Map

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 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

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.

Post Views: 4