C# 喜欢 VBA 中的 List

Question

我想在 VBA 上创建一个 List<T> ，就像你在 C# 上创建的一样，有什么办法可以做到吗？我在 SO 上寻找有关它的问题，但找不到任何问题。

Answer 1

泛型出现在 C# 2.0 中；在 VB6/VBA 中，最接近的是 Collection 。让您Add，Remove和Count，但你需要，如果你想要更多的功能，如AddRange，Clear和Contains用自己的类来包装它。
Collection 取任何 Variant(即你扔给它的任何东西)，所以你必须通过验证被添加的项目的类型来强制执行 <T>。 TypeName() 函数可能对此有用。

我接受了挑战:)

更新 see original code here

列表文件

向您的 VB6/VBA 项目添加一个新的类模块。这将定义我们正在实现的 List<T> 的功能。正如 [Santosh] 的回答所示，我们在选择要包装的集合结构方面受到了一些限制。我们可以使用数组，但是作为对象的集合是一个更好的候选对象，因为我们希望枚举器在 List 构造中使用我们的 For Each。

类型安全
List<T> 的事情是 T 说这个列表是一个确切类型的列表，并且约束意味着一旦我们确定 T 的类型，该列表实例就会坚持下去。在 VB6 中，我们可以使用 TypeName 来获取一个表示我们正在处理的类型名称的字符串，所以我的方法是让列表知道在添加第一项的那一刻它所持有的类型的名称:什么C# 在 VB6 中以声明方式实现，我们可以将其作为运行时实现。但这是 VB6，所以让我们不要为保留数值类型的类型安全而发疯——我的意思是我们可以在这里比 VB6 更聪明，这是我们想要的，归根结底它不是 C# 代码；该语言对此不是很严格，因此折衷方案可能是仅允许对大小小于列表中第一项大小的数字类型进行隐式类型转换。

Private Type tList
    Encapsulated As Collection
    ItemTypeName As String
End Type
Private this As tList
Option Explicit

Private Function IsReferenceType() As Boolean
    If this.Encapsulated.Count = 0 Then IsReferenceType = False: Exit Function
    IsReferenceType = IsObject(this.Encapsulated(1))
End Function

Public Property Get NewEnum() As IUnknown
    Attribute NewEnum.VB_Description = "Gets the enumerator from encapsulated collection."
    Attribute NewEnum.VB_UserMemId = -4
    Attribute NewEnum.VB_MemberFlags = "40"

    Set NewEnum = this.Encapsulated.[_NewEnum]
End Property

Private Sub Class_Initialize()
    Set this.Encapsulated = New Collection
End Sub

Private Sub Class_Terminate()
    Set this.Encapsulated = Nothing
End Sub

验证值是否为适当的类型可以是一个函数的角色，为方便起见，可以将其设为 public，因此在实际添加值之前，客户端代码可以测试该值是否有效。每次我们初始化 New List 时， this.ItemTypeName 都是该实例的空字符串；剩下的时间我们可能会看到正确的类型，所以让我们不要费心检查所有的可能性(不是 C#，评估不会在 Or 语句之后的第一个 true 处中断):

Public Function IsTypeSafe(value As Variant) As Boolean

    Dim result As Boolean
    result = this.ItemTypeName = vbNullString Or this.ItemTypeName = TypeName(value)
    If result Then GoTo QuickExit

    result = result _
        Or this.ItemTypeName = "Integer" And StringMatchesAny(TypeName(value), "Byte") _
        Or this.ItemTypeName = "Long" And StringMatchesAny(TypeName(value), "Integer", "Byte") _
        Or this.ItemTypeName = "Single" And StringMatchesAny(TypeName(value), "Long", "Integer", "Byte") _
        Or this.ItemTypeName = "Double" And StringMatchesAny(TypeName(value), "Long", "Integer", "Byte", "Single") _
        Or this.ItemTypeName = "Currency" And StringMatchesAny(TypeName(value), "Long", "Integer", "Byte", "Single", "Double")

QuickExit:
    IsTypeSafe = result
End Function

现在这是一个开始。

所以我们有一个 Collection 。这为我们购买了 Count 、 Add 、 Remove 和 Item 。现在后者很有趣，因为它也是 Collection 的默认属性，在 C# 中它被称为索引器属性。在 VB6 中，我们将 Item.VB_UserMemId 属性设置为 0，我们得到一个默认属性:

Public Property Get Item(ByVal index As Long) As Variant
    Attribute Item.VB_Description = "Gets/sets the item at the specified index."
    Attribute Item.VB_UserMemId = 0

    If IsReferenceType Then
        Set Item = this.Encapsulated(index)
    Else
        Item = this.Encapsulated(index)
    End If
End Property

程序属性

在 VBA 中，IDE 不提供任何编辑方式，但您可以在记事本中编辑代码并将编辑后的 ​​.cls 文件导入到您的 VBA 项目中。在 VB6 中，您有一个工具菜单来编辑这些:



Attribute NewEnum.VB_UserMemId = -4 告诉 VB 使用这个属性来提供一个枚举器——我们只是将封装的 Collection 传递给它，它是一个隐藏的属性，它以下划线开头(不要在家里尝试这个!)。 Attribute NewEnum.VB_MemberFlags = "40" 也应该使它成为一个隐藏的属性，但我还没有弄清楚为什么 VB 不会接受那个。因此，为了调用该隐藏属性的 getter，我们需要用 [] 方括号将其括起来，因为在 VB6/VBA 中标识符不能合法地以下划线开头。

One nice thing about the NewEnum.VB_Description attribute is that whatever description you enter there, shows up in the Object Browser (F2) as a description/mini-documentation for your code.

物品配件/“二传手”

VB6/VBA Collection 不允许直接将值写入其项目。我们可以分配引用，但不能分配值。我们可以通过为 List 属性提供 setter 来实现允许写入的 Item - 因为我们不知道我们的 T 是一个值还是一个引用/对象，我们将提供 0x232311 和 0x231411 访问由于 Let 不支持这一点，我们必须首先删除指定索引处的项目，然后在该位置插入新值。

好消息， Set 和 Collection 是我们无论如何都必须实现的两种方法，并且 RemoveAt 是免费的，因为它的语义与封装的 0x31134322 的语义相同

Public Sub RemoveAt(ByVal index As Long)
    this.Encapsulated.Remove index
End Sub

Public Sub RemoveRange(ByVal Index As Long, ByVal valuesCount As Long)
    Dim i As Long
    For i = Index To Index + valuesCount - 1
        RemoveAt Index
    Next
End Sub

我对 Insert 的实现感觉它可以变得更好，但它本质上是“抓取指定索引之后的所有内容，制作副本；删除指定索引之后的所有内容；添加指定值，然后添加其余项目”:

Public Sub Insert(ByVal index As Long, ByVal value As Variant)
    Dim i As Long, isObjRef As Boolean
    Dim tmp As New List

    If index > Count Then Err.Raise 9  'index out of range

    For i = index To Count
        tmp.Add Item(i)
    Next

    For i = index To Count
        RemoveAt index
    Next

    Add value
    Append tmp

End Sub

RemoveAt 可以取一个 Collection 所以我们可以提供内联值:

Public Sub InsertRange(ByVal Index As Long, ParamArray values())
    Dim i As Long, isObjRef As Boolean
    Dim tmp As New List

    If Index > Count Then Err.Raise 9  'index out of range

    For i = Index To Count
        tmp.Add Item(i)
    Next

    For i = Index To Count
        RemoveAt Index
    Next

    For i = LBound(values) To UBound(values)
        Add values(i)
    Next
    Append tmp

End Sub

Insert 与排序无关，所以我们可以马上实现:

Public Sub Reverse()
    Dim i As Long, tmp As New List

    Do Until Count = 0
        tmp.Add Item(Count)
        RemoveAt Count
    Loop

    Append tmp

End Sub

我想，因为 VB6 不支持重载。有一种方法可以添加另一个列表中的所有项目会很好，所以我称之为 InsertRange :

Public Sub Append(ByRef values As List)
    Dim value As Variant, i As Long
    For i = 1 To values.Count
        Add values(i)
    Next
End Sub

ParamArray 是我们的 Reverse 不仅仅是一个封装的 Append 和几个额外的方法的地方:如果它是添加到列表中的第一个项目，我们有一个逻辑要在这里执行 - 不关心有多少项目有在封装的集合中，因此如果从列表中删除所有项目，则 Add 的类型仍然受到限制:

Public Sub Add(ByVal value As Variant)
    If this.ItemTypeName = vbNullString Then this.ItemTypeName = TypeName(value)
    If Not IsTypeSafe(value) Then Err.Raise 13, ToString, "Type Mismatch. Expected: '" & this.ItemTypeName & "'; '" & TypeName(value) & "' was supplied." 'Type Mismatch
    this.Encapsulated.Add value
End Sub

List 失败时引发的错误来源是调用 Collection 的结果，该方法返回...类型的名称，包括 T 的类型 - 因此我们可以将其设为 0x25181223134310224131310x2513134313241

Public Function ToString() As String
    ToString = TypeName(Me) & "<" & Coalesce(this.ItemTypeName, "Variant") & ">"
End Function

T 允许一次添加多个项目。起初，我使用参数值数组实现了 Add，但后来使用时我又想到，这不是 C#，而采用 ToString 更方便:

Public Sub AddRange(ParamArray values())
    Dim value As Variant, i As Long
    For i = LBound(values) To UBound(values)
        Add values(i)
    Next
End Sub

...然后我们得到那些 List<T> setter:

Public Property Let Item(ByVal index As Long, ByVal value As Variant)
    RemoveAt index
    Insert index, value
End Property

Public Property Set Item(ByVal index As Long, ByVal value As Variant)
    RemoveAt index
    Insert index, value
End Property

通过提供值而不是索引来删除项目，需要另一种方法来为我们提供该值的索引，并且因为我们不仅支持值类型还支持引用类型，这将非常有趣，因为现在我们需要一种方法来确定引用类型之间的相等性 - 我们可以通过比较 List(Of T) 来获得引用相等性，但我们将需要的不仅仅是这个 - .net 框架教会了我 List<T> 和 AddRange 。让我们将这两个接口(interface)合二为一，并将其​​命名为 ParamArray - 是的，您可以在 VB6/VBA 中编写和实现接口(interface)。

IComparable.cls

添加一个新的类模块并将其命名为 Item - 如果您真的打算将它们用于其他用途，那么您可以将它们放在两个单独的类模块中并调用另一个类模块 ObjPtr(value) ，但这将使您实现两个接口(interface)而不是一个，对于您希望能够使用的所有引用类型。

这不是模型代码，所需要的只是方法签名 :

Option Explicit

Public Function CompareTo(other As Variant) As Integer
'Compares this instance with another; returns one of the following values:
'   -1 if [other] is smaller than this instance.
'    1 if [other] is greater than this instance.
'    0 otherwise.
End Function

Public Function Equals(other As Variant) As Boolean
'Compares this instance with another; returns true if the two instances are equal.
End Function

列表文件

使用 IComparable 接口(interface)

鉴于我们已经将 IComparable 与 IEquatable 和 IComparable 打包在一起，我们现在可以在列表中找到任何值的索引；我们还可以确定列表是否包含任何指定的值:

Public Function IndexOf(value As Variant) As Long
    Dim i As Long, isRef As Boolean, comparable As IComparable
    isRef = IsReferenceType
    For i = 1 To this.Encapsulated.Count
        If isRef Then
            If TypeOf this.Encapsulated(i) Is IComparable And TypeOf value Is IComparable Then
                Set comparable = this.Encapsulated(i)
                If comparable.Equals(value) Then
                    IndexOf = i
                    Exit Function
                End If
            Else
                'reference type isn't comparable: use reference equality
                If ObjPtr(this.Encapsulated(i)) = ObjPtr(value) Then
                    IndexOf = i
                    Exit Function
                End If
            End If
        Else
            If this.Encapsulated(i) = value Then
                IndexOf = i
                Exit Function
            End If
        End If
    Next
    IndexOf = -1
End Function

Public Function Contains(value As Variant) As Boolean
    Dim v As Variant, isRef As Boolean, comparable As IComparable
    isRef = IsReferenceType
    For Each v In this.Encapsulated
        If isRef Then
            If TypeOf v Is IComparable And TypeOf value Is IComparable Then
                Set comparable = v
                If comparable.Equals(value) Then Contains = True: Exit Function
            Else
                'reference type isn't comparable: use reference equality
                If ObjPtr(v) = ObjPtr(value) Then Contains = True: Exit Function
            End If
        Else
            If v = value Then Contains = True: Exit Function
        End If
    Next
End Function

当我们开始询问 IComparable 和 IEquatable 值可能是什么时， IComparable 方法开始发挥作用:

Public Function Min() As Variant
    Dim i As Long, isRef As Boolean
    Dim smallest As Variant, isSmaller As Boolean, comparable As IComparable

    isRef = IsReferenceType
    For i = 1 To Count

        If isRef And IsEmpty(smallest) Then
            Set smallest = Item(i)
        ElseIf IsEmpty(smallest) Then
            smallest = Item(i)
        End If

        If TypeOf Item(i) Is IComparable Then
            Set comparable = Item(i)
            isSmaller = comparable.CompareTo(smallest) < 0
        Else
            isSmaller = Item(i) < smallest
        End If

        If isSmaller Then
            If isRef Then
                Set smallest = Item(i)
            Else
                smallest = Item(i)
            End If
        End If
    Next

    If isRef Then
        Set Min = smallest
    Else
        Min = smallest
    End If

End Function

Public Function Max() As Variant
    Dim i As Long, isRef As Boolean
    Dim largest As Variant, isLarger As Boolean, comparable As IComparable

    isRef = IsReferenceType
    For i = 1 To Count

        If isRef And IsEmpty(largest) Then
            Set largest = Item(i)
        ElseIf IsEmpty(largest) Then
            largest = Item(i)
        End If

        If TypeOf Item(i) Is IComparable Then
            Set comparable = Item(i)
            isLarger = comparable.CompareTo(largest) > 0
        Else
            isLarger = Item(i) > largest
        End If

        If isLarger Then
            If isRef Then
                Set largest = Item(i)
            Else
                largest = Item(i)
            End If
        End If
    Next

    If isRef Then
        Set Max = largest
    Else
        Max = largest
    End If

End Function

这两个函数允许一个非常可读的排序——因为这里发生了什么(添加和删除项目)，我们将不得不快速失败:

Public Sub Sort()
    If Not IsNumeric(First) And Not this.ItemTypeName = "String" And Not TypeOf First Is IComparer Then Err.Raise 5, ToString, "Invalid operation: Sort() requires a list of numeric or string values, or a list of objects implementing the IComparer interface."
    Dim i As Long, value As Variant, tmp As New List, minValue As Variant, isRef As Boolean

    isRef = IsReferenceType
    Do Until Count = 0

        If isRef Then
            Set minValue = Min
        Else
            minValue = Min
        End If

        tmp.Add minValue
        RemoveAt IndexOf(minValue)
    Loop

    Append tmp

End Sub

Public Sub SortDescending()
    If Not IsNumeric(First) And Not this.ItemTypeName = "String" And Not TypeOf First Is IComparer Then Err.Raise 5, ToString, "Invalid operation: SortDescending() requires a list of numeric or string values, or a list of objects implementing the IComparer interface."
    Dim i As Long, value As Variant, tmp As New List, maxValue As Variant, isRef As Boolean

    isRef = IsReferenceType
    Do Until Count = 0

        If isRef Then
            Set maxValue = Max
        Else
            maxValue = Max
        End If

        tmp.Add maxValue
        RemoveAt IndexOf(maxValue)
    Loop

    Append tmp

End Sub

最后一击

剩下的只是琐碎的事情:

Public Sub Remove(value As Variant)
    Dim index As Long
    index = IndexOf(value)
    If index <> -1 Then this.Encapsulated.Remove index
End Sub

Public Property Get Count() As Long
    Count = this.Encapsulated.Count
End Property

Public Sub Clear()
    Do Until Count = 0
        this.Encapsulated.Remove 1
    Loop
End Sub

Public Function First() As Variant
    If Count = 0 Then Exit Function
    If IsObject(Item(1)) Then
        Set First = Item(1)
    Else
        First = Item(1)
    End If
End Function

Public Function Last() As Variant
    If Count = 0 Then Exit Function
    If IsObject(Item(Count)) Then
        Set Last = Item(Count)
    Else
        Last = Item(Count)
    End If
End Function

关于 CompareTo 的一件有趣的事情是，只需在其上调用 Equals 即可将其复制到数组中 - 我们可以做到这一点:

Public Function ToArray() As Variant()

    Dim result() As Variant
    ReDim result(1 To Count)

    Dim i As Long
    If Count = 0 Then Exit Function

    If IsReferenceType Then
        For i = 1 To Count
            Set result(i) = this.Encapsulated(i)
        Next
    Else
        For i = 1 To Count
            result(i) = this.Encapsulated(i)
        Next
    End If

    ToArray = result
End Function

就这样!

我正在使用一些辅助函数，它们在这里 - 它们可能属于某些 CompareTo 代码模块:

Public Function StringMatchesAny(ByVal string_source As String, find_strings() As Variant) As Boolean

    Dim find As String, i As Integer, found As Boolean

    For i = LBound(find_strings) To UBound(find_strings)

        find = CStr(find_strings(i))
        found = (string_source = find)

        If found Then Exit For
    Next

    StringMatchesAny = found

End Function

Public Function Coalesce(ByVal value As Variant, Optional ByVal value_when_null As Variant = 0) As Variant

    Dim return_value As Variant
    On Error Resume Next 'supress error handling

    If IsNull(value) Or (TypeName(value) = "String" And value = vbNullString) Then
        return_value = value_when_null
    Else
        return_value = value
    End If

    Err.Clear 'clear any errors that might have occurred
    On Error GoTo 0 'reinstate error handling

    Coalesce = return_value

End Function

MyClass.cls

此实现要求，当 Min 是引用类型/对象时，该类实现 Max 接口(interface)以便可排序和查找值的索引。这是它的完成方式 - 假设您有一个名为 List<T> 的类，其中包含一个名为 ToArray() 的数字或 StringHelpers 属性:

Implements IComparable
Option Explicit

Private Function IComparable_CompareTo(other As Variant) As Integer
    Dim comparable As MyClass
    If Not TypeOf other Is MyClass Then Err.Raise 5

    Set comparable = other
    If comparable Is Nothing Then IComparable_CompareTo = 1: Exit Function

    If Me.SomeProperty < comparable.SomeProperty Then
        IComparable_CompareTo = -1
    ElseIf Me.SomeProperty > comparable.SomeProperty Then
        IComparable_CompareTo = 1
    End If

End Function

Private Function IComparable_Equals(other As Variant) As Boolean
    Dim comparable As MyClass
    If Not TypeOf other Is MyClass Then Err.Raise 5

    Set comparable = other
    IComparable_Equals = comparable.SomeProperty = Me.SomeProperty

End Function

T 可以这样使用:

Dim myList As New List
myList.AddRange 1, 12, 123, 1234, 12345 ', 123456 would blow up because it's a Long
myList.SortDescending

Dim value As Variant
For Each value In myList
   Debug.Print Value
Next

Debug.Print myList.IndexOf(123) 'prints 3
Debug.Print myList.ToString & ".IsTypeSafe(""abc""): " & myList.IsTypeSafe("abc")
    ' prints List<Integer>.IsTypeSafe("abc"): false