Skip to main content
Code Review

Return to Question

replaced http://codereview.stackexchange.com/ with https://codereview.stackexchange.com/
Source Link

A couple helper functions are also used here and there in the class' code - I'm not asking for a review of those, but if you are interested to see more, StringFormat is a custom C#-style VB6/VBA implementation of string.Format() covered here here, StringMatchesAny is a custom string helper function covered here here, and Coalesce is a simple null-replacement function that considers an empty string as a null value.

A couple helper functions are also used here and there in the class' code - I'm not asking for a review of those, but if you are interested to see more, StringFormat is a custom C#-style VB6/VBA implementation of string.Format() covered here, StringMatchesAny is a custom string helper function covered here, and Coalesce is a simple null-replacement function that considers an empty string as a null value.

A couple helper functions are also used here and there in the class' code - I'm not asking for a review of those, but if you are interested to see more, StringFormat is a custom C#-style VB6/VBA implementation of string.Format() covered here, StringMatchesAny is a custom string helper function covered here, and Coalesce is a simple null-replacement function that considers an empty string as a null value.

Notice removed Reward existing answer by RubberDuck
Bounty Ended with Comintern's answer chosen by RubberDuck
Tweeted twitter.com/#!/StackCodeReview/status/482884153713909760
Notice added Reward existing answer by RubberDuck
Bounty Started worth 50 reputation by RubberDuck
edited tags
Link
Jeff Vanzella
  • 4.3k
  • 2
  • 24
  • 33
removed clutter
Source Link
Mathieu Guindon
  • 75.5k
  • 18
  • 194
  • 467

I'm including the raw notepad-view class because there are procedure attributes involved :)

VERSION 1.0 CLASS
BEGIN
 MultiUse = -1 'True
 Persistable = 0 'NotPersistable
 DataBindingBehavior = 0 'vbNone
 DataSourceBehavior = 0 'vbNone
 MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "List"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Private Type tList
 Encapsulated As Collection
 ItemTypeName As String
End Type
Private this As tList
Option Explicit
Private Function IsReferenceType() As Boolean
 If Count = 0 Then Exit Function
 IsReferenceType = IsObject(this.Encapsulated(1))
End Function
Private Function IsComparable() As Boolean
 If IsReferenceType Then
 IsComparable = TypeOf First Is IComparable
 End If
End Function
Private Function CompareReferenceTypes(value As Variant, other As Variant) As Integer
 
 Dim comparable As IComparable
 
 If IsComparable Then
 
 Set comparable = value
 CompareReferenceTypes = comparable.CompareTo(other)
 
 Else
 
 RaiseErrorMustImplementIComparable "CompareReferenceTypes()"
 
 End If
 
End Function
Private Function CompareValueTypes(value As Variant, other As Variant) As Integer
 
 If value < other Then
 
 CompareValueTypes = -1
 
 ElseIf value > other Then
 
 CompareValueTypes = 1
 
 End If
 
End Function
Private Function IsEquatable() As Boolean
 If IsReferenceType Then
 IsEquatable = TypeOf First Is IEquatable
 End If
End Function
Private Function EquateReferenceTypes(value As Variant, other As Variant) As Boolean
 
 Dim equatable As IEquatable
 If IsEquatable Then
 
 Set equatable = value
 EquateReferenceTypes = equatable.Equals(other)
 
 Else
 
 Debug.Print "WARNING: Reference type doesn't implement IEquatable, using reference equality."
 EquateReferenceTypes = (ObjPtr(value) = ObjPtr(other))
 
 End If
 
End Function
Private Function EquateValueTypes(value As Variant, other As Variant) As Boolean
 
 EquateValueTypes = (value = other)
End Function
Private Function ValidateItemType(value As Variant)
 
 If this.ItemTypeName = vbNullString Then this.ItemTypeName = TypeName(value)
 ValidateItemType = IsTypeSafe(value)
 
End Function
Private Sub RaiseErrorUnsafeType(member As String, suppliedType As String)
 Err.Raise 13, StringFormat("{0}.{1}", ToString, member), _
 StringFormat("Type Mismatch. Expected: '{0}', '{1}' was supplied.", this.ItemTypeName, suppliedType)
End Sub
Private Sub RaiseErrorMustImplementIComparable(member As String)
 Err.Raise 5, StringFormat("{0}.{1}", ToString, member), "Invalid operation: method requires a list of numeric, date or string values, or a list of objects implementing the IComparable interface."
End Sub
Private Sub Class_Initialize()
 Set this.Encapsulated = New Collection
End Sub
Private Sub Class_Terminate()
 Set this.Encapsulated = Nothing
End Sub
Public Property Get Item(ByVal Index As Long) As Variant
Attribute Item.VB_Description = "Gets or sets the element at the specified index."
Attribute Item.VB_UserMemId = 0
'Gets the element at the specified index.
 
 If IsReferenceType Then
 Set Item = this.Encapsulated(Index)
 Else
 Item = this.Encapsulated(Index)
 End If
End Property
Public Property Let Item(ByVal Index As Long, ByVal value As Variant)
'Sets the element at the specified index.
 If Not IsTypeSafe(value) Then RaiseErrorUnsafeType "Item(Let)", TypeName(value)
 
 RemoveAt Index
 If Index = Count Then
 Add value
 Else
 Insert Index, value
 End If
 
End Property
Public Property Set Item(ByVal Index As Long, ByVal value As Variant)
'Sets the element at the specified index.
 
 If Not IsTypeSafe(value) Then RaiseErrorUnsafeType "Item(Set)", TypeName(value)
 
 RemoveAt Index
 If Index = Count Then
 Add value
 Else
 Insert Index, value
 End If
 
End Property
Public Property Get NewEnum() As IUnknown
Attribute NewEnum.VB_Description = "Gets an enumerator that iterates through the List."
Attribute NewEnum.VB_UserMemId = -4
Attribute NewEnum.VB_MemberFlags = "40"
'Gets an enumerator that iterates through the List.
 
 Set NewEnum = this.Encapsulated.[_NewEnum]
End Property
Public Property Get Count() As Long
Attribute Count.VB_Description = "Gets the number of elements contained in the List."
'Gets the number of elements contained in the List.
 
 Count = this.Encapsulated.Count
End Property
Attribute Add.VB_Description = "Adds an object to the end of the List."
Attribute AddArray.VB_Description = "Adds the specified elements to the end of the List."
Attribute AddRange.VB_Description = "Adds the elements of the specified List to the end of the List."
Attribute AddValues.VB_Description = "Adds the specified elements to the end of the List."
Attribute Clear.VB_Description = "Removes all elements from the List."
Attribute Contains.VB_Description = "Determines whether an element is in the List."
Attribute First.VB_Description = "Returns the first element of the List."
Attribute GetRange.VB_Description = "Creates a copy of a range of elements in the source List."
Attribute IndexOf.VB_Description = "Searches for the specified object and returns the 1-based index of the first occurrence within the entire List."
 If Count = 0 Then IndexOf = -1: Exit Function
 For i = 1 To Count
 
 If isRef Then
 
 found = EquateReferenceTypes(value, Item(i))
 
 Else
 
 found = EquateValueTypes(value, Item(i))
 
 End If
 
 If found Then IndexOf = i: Exit Function
 
 Next
 
 IndexOf = -1
 
End Function
Public Sub Insert(ByVal Index As Long, value As Variant)
Attribute Insert.VB_Description = "Inserts an element into the List at the specified index."
'Inserts an element into the List at the specified index.
 
 Dim tmp As List
 Set tmp = GetRange(Index, Count)
 
 RemoveRange Index, Count
 
 Add value
 AddRange tmp
 
End Sub
Public Sub InsertArray(ByVal Index As Long, values() As Variant)
Attribute InsertArray.VB_Description = "Inserts the specified elements into the List at the specified index."
'Inserts the specified elements into the List at the specified index.
 
 Dim tmp As List
 Set tmp = GetRange(Index, Count)
 
 RemoveRange Index, Count
 
 AddArray values
 AddRange tmp
End Sub
Public Sub InsertRange(ByVal Index As Long, values As List)
Attribute InsertRange.VB_Description = "Inserts the specified elements into the List at the specified index."
'Inserts the specified elements into the List at the specified index.
 Dim tmp As List
 Set tmp = GetRange(Index, Count)
 
 RemoveRange Index, Count
 
 AddRange values
 AddRange tmp
 
End Sub
Public Sub InsertValues(ByVal Index As Long, ParamArray values())
Attribute InsertValues.VB_Description = "Inserts the specified elements into the List at the specified index."
'Inserts the specified elements into the List at the specified index.
 Dim valuesArray() As Variant
 valuesArray = values
 
 InsertArray Index, valuesArray
 
End Sub
Public Function IsSortable() As Boolean
Attribute IsSortable.VB_Description = "Determines whether the List can be sorted."
'Determines whether the List can be sorted.
 
 If Count = 0 Then Exit Function
 
 Dim firstItem As Variant
 If IsReferenceType Then
 Set firstItem = First
 Else
 firstItem = First
 End If
 
 IsSortable = IsNumeric(firstItem) _
 Or IsDate(firstItem) _
 Or this.ItemTypeName = "String" _
 Or IsComparable
 
End Function
Public Function IsTypeSafe(value As Variant) As Boolean
Attribute IsTypeSafe.VB_Description = "Determines whether a value can be safely added to the List."
'Determines whether a value can be safely added to the List.
'Returns true if the type of specified value matches the type of items already in the list,
'or it the type of specified value is a numeric type smaller than the type of items already in the list.
'This means a List<Long> can contain Integer values, but a List<Integer> cannot contain Long values.
 
 Dim result As Boolean
 
 'most common cases: this.ItemTypeName isn't yet defined, or matches TypeName(value):
 result = this.ItemTypeName = vbNullString Or this.ItemTypeName = TypeName(value)
 If result Then IsTypeSafe = result: Exit Function
 
 'all other cases demand more processing:
 IsTypeSafe = 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")
 
End Function
Public Function Last() As Variant
Attribute Last.VB_Description = "Returns the last element of the List."
'Returns the last element of the List.
 
 If Count = 0 Then Exit Function
 If IsReferenceType Then
 Set Last = Item(Count)
 Else
 Last = Item(Count)
 End If
End Function
Public Function LastIndexOf(value As Variant) As Long
Attribute LastIndexOf.VB_Description = "Searches for the specified object and returns the 1-based index of the last occurrence within the entire List."
'Searches for the specified object and returns the 1-based index of the last occurrence within the entire List.
 
 Dim found As Boolean
 Dim isRef As Boolean
 isRef = IsReferenceType
 
 LastIndexOf = -1
 If Count = 0 Then Exit Function
 Dim i As Long
 For i = 1 To Count
 
 If isRef Then
 
 found = EquateReferenceTypes(value, Item(i))
 
 Else
 
 found = EquateValueTypes(value, Item(i))
 
 End If
 
 If found Then LastIndexOf = i
 
 Next
 
End Function
Public Function Max() As Variant
Attribute Max.VB_Description = "Returns the maximum value in the List."
'Returns the maximum value in the List.
 
 Dim isRef As Boolean
 isRef = IsReferenceType
 
 Dim largest As Variant
 Dim isLarger As Boolean
 
 Dim i As Long
 For i = 1 To Count
 
 If isRef Then
 
 If IsEmpty(largest) Then Set largest = Item(i)
 isLarger = CompareReferenceTypes(Item(i), largest) > 0
 
 If isLarger Or IsEmpty(Max) Then
 Set largest = Item(i)
 Set Max = largest
 End If
 
 Else
 
 If IsEmpty(largest) Then largest = Item(i)
 isLarger = CompareValueTypes(Item(i), largest) > 0
 
 If isLarger Or IsEmpty(Max) Then
 largest = Item(i)
 Max = largest
 End If
 
 End If
 
 
 Next
End Function
Public Function Min() As Variant
Attribute Min.VB_Description = "Returns the minimum value in the List."
'Returns the minimum value in the List.
 
 Dim isRef As Boolean
 isRef = IsReferenceType
 
 Dim smallest As Variant
 Dim isSmaller As Boolean
 
 Dim i As Long
 For i = 1 To Count
 
 If isRef Then
 
 If IsEmpty(smallest) Then Set smallest = Item(i)
 isSmaller = CompareReferenceTypes(Item(i), smallest) < 0
 
 If isSmaller Or IsEmpty(Min) Then
 Set smallest = Item(i)
 Set Min = smallest
 End If
 
 Else
 
 If IsEmpty(smallest) Then smallest = Item(i)
 isSmaller = CompareValueTypes(Item(i), smallest) < 0
 
 If isSmaller Or IsEmpty(Min) Then
 smallest = Item(i)
 Min = smallest
 End If
 
 End If
 
 
 Next
 
End Function
Public Sub Reverse()
Attribute Reverse.VB_Description = "Reverses the order of the elements in the entire List."
'Reverses the order of the elements in the entire List.
 
 Dim tmp As New List
 Do Until Count = 0
 
 tmp.Add Item(Count)
 RemoveAt Count
 
 Loop
 
 AddRange tmp
 
End Sub
Public Sub Remove(ParamArray values())
Attribute Remove.VB_Description = "Removes the first occurrence of specified object(s) from the List."
'Removes the first occurrence of specified object(s) from the List.
 
 Dim i As Long
 Dim Index As Long
 
 For i = LBound(values) To UBound(values)
 
 Index = IndexOf(values(i))
 If Index <> -1 Then RemoveAt Index
 
 Next
End Sub
Public Sub RemoveAt(ByVal Index As Long)
Attribute RemoveAt.VB_Description = "Removes the element at the specified index of the List."
'Removes the element at the specified index of the List.
 
 this.Encapsulated.Remove Index
End Sub
Public Sub RemoveRange(ByVal Index As Long, ByVal valuesCount As Long)
Attribute RemoveRange.VB_Description = "Removes a range of elements from the List."
'Removes a range of elements from the List.
 
 Dim i As Long
 For i = Index To Index + valuesCount - 1
 
 RemoveAt Index
 
 Next
 
End Sub
Public Sub Sort()
Attribute Sort.VB_Description = "Sorts the elements in the entire List."
'Sorts the elements in the entire List.
 Dim tmp As List
 Dim minValue As Variant
 
 If Not IsSortable Then RaiseErrorMustImplementIComparable "Sort()"
 
 Dim isRef As Boolean
 isRef = IsReferenceType
 
 Set tmp = New List
 Do Until Count = 0
 
 If isRef Then
 
 Set minValue = Min
 
 Else
 
 minValue = Min
 
 End If
 
 tmp.Add minValue
 Remove minValue
 
 Loop
 
 AddRange tmp
 
End Sub
Public Sub SortDescending()
Attribute SortDescending.VB_Description = "Sorts the elements in the entire List, in descending order."
'Sorts the elements in the entire List, in descending order.
 
 Dim tmp As List
 Dim maxValue As Variant
 
 If Not IsSortable Then RaiseErrorMustImplementIComparable "SortDescending()"
 
 Dim isRef As Boolean
 isRef = IsReferenceType
 
 Set tmp = New List
 Do Until Count = 0
 
 If isRef Then
 Set maxValue = Max
 Else
 maxValue = Max
 End If
 
 tmp.Add maxValue
 Remove maxValue
 
 Loop
 
 AddRange tmp
 
End Sub
Public Function ToArray() As Variant()
Attribute ToArray.VB_Description = "Copies the elements of the List to a new array."
'Copies the elements of the List to a new array.
 
 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) = Item(i)
 Next
 Else
 For i = 1 To Count
 result(i) = Item(i)
 Next
 End If
 
 ToArray = result
 
End Function
Public Function ToString() As String
Attribute ToString.VB_Description = "Returns a string that represents the current List object."
'Returns a string that represents the current List object.
 
 ToString = StringFormat("{0}<{1}>", TypeName(Me), Coalesce(this.ItemTypeName, "Variant"))
End Function

IComparable:

VERSION 1.0 CLASS
BEGIN
 MultiUse = -1 'True
 Persistable = 0 'NotPersistable
 DataBindingBehavior = 0 'vbNone
 DataSourceBehavior = 0 'vbNone
 MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "IComparable"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
Public Function CompareTo(other As Variant) As Integer
Attribute CompareTo.VB_Description = "Compares the current instance with another object of the same type and returns an integer that indicates whether the current instance precedes, follows, or occurs in the same position in the sort order as the other object."
End Function
VERSION 1.0 CLASS
BEGIN
 MultiUse = -1 'True
 Persistable = 0 'NotPersistable
 DataBindingBehavior = 0 'vbNone
 DataSourceBehavior = 0 'vbNone
 MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "IEquatable"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
Public Function Equals(other As Variant) As Boolean
End Function

IEquatable:

Option Explicit
Public Function Equals(other As Variant) As Boolean
End Function

I'm including the raw notepad-view class because there are procedure attributes involved :)

VERSION 1.0 CLASS
BEGIN
 MultiUse = -1 'True
 Persistable = 0 'NotPersistable
 DataBindingBehavior = 0 'vbNone
 DataSourceBehavior = 0 'vbNone
 MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "List"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Private Type tList
 Encapsulated As Collection
 ItemTypeName As String
End Type
Private this As tList
Option Explicit
Private Function IsReferenceType() As Boolean
 If Count = 0 Then Exit Function
 IsReferenceType = IsObject(this.Encapsulated(1))
End Function
Private Function IsComparable() As Boolean
 If IsReferenceType Then
 IsComparable = TypeOf First Is IComparable
 End If
End Function
Private Function CompareReferenceTypes(value As Variant, other As Variant) As Integer
 
 Dim comparable As IComparable
 
 If IsComparable Then
 
 Set comparable = value
 CompareReferenceTypes = comparable.CompareTo(other)
 
 Else
 
 RaiseErrorMustImplementIComparable "CompareReferenceTypes()"
 
 End If
 
End Function
Private Function CompareValueTypes(value As Variant, other As Variant) As Integer
 
 If value < other Then
 
 CompareValueTypes = -1
 
 ElseIf value > other Then
 
 CompareValueTypes = 1
 
 End If
 
End Function
Private Function IsEquatable() As Boolean
 If IsReferenceType Then
 IsEquatable = TypeOf First Is IEquatable
 End If
End Function
Private Function EquateReferenceTypes(value As Variant, other As Variant) As Boolean
 
 Dim equatable As IEquatable
 If IsEquatable Then
 
 Set equatable = value
 EquateReferenceTypes = equatable.Equals(other)
 
 Else
 
 Debug.Print "WARNING: Reference type doesn't implement IEquatable, using reference equality."
 EquateReferenceTypes = (ObjPtr(value) = ObjPtr(other))
 
 End If
 
End Function
Private Function EquateValueTypes(value As Variant, other As Variant) As Boolean
 
 EquateValueTypes = (value = other)
End Function
Private Function ValidateItemType(value As Variant)
 
 If this.ItemTypeName = vbNullString Then this.ItemTypeName = TypeName(value)
 ValidateItemType = IsTypeSafe(value)
 
End Function
Private Sub RaiseErrorUnsafeType(member As String, suppliedType As String)
 Err.Raise 13, StringFormat("{0}.{1}", ToString, member), _
 StringFormat("Type Mismatch. Expected: '{0}', '{1}' was supplied.", this.ItemTypeName, suppliedType)
End Sub
Private Sub RaiseErrorMustImplementIComparable(member As String)
 Err.Raise 5, StringFormat("{0}.{1}", ToString, member), "Invalid operation: method requires a list of numeric, date or string values, or a list of objects implementing the IComparable interface."
End Sub
Private Sub Class_Initialize()
 Set this.Encapsulated = New Collection
End Sub
Private Sub Class_Terminate()
 Set this.Encapsulated = Nothing
End Sub
Public Property Get Item(ByVal Index As Long) As Variant
Attribute Item.VB_Description = "Gets or sets the element at the specified index."
Attribute Item.VB_UserMemId = 0
'Gets the element at the specified index.
 
 If IsReferenceType Then
 Set Item = this.Encapsulated(Index)
 Else
 Item = this.Encapsulated(Index)
 End If
End Property
Public Property Let Item(ByVal Index As Long, ByVal value As Variant)
'Sets the element at the specified index.
 If Not IsTypeSafe(value) Then RaiseErrorUnsafeType "Item(Let)", TypeName(value)
 
 RemoveAt Index
 If Index = Count Then
 Add value
 Else
 Insert Index, value
 End If
 
End Property
Public Property Set Item(ByVal Index As Long, ByVal value As Variant)
'Sets the element at the specified index.
 
 If Not IsTypeSafe(value) Then RaiseErrorUnsafeType "Item(Set)", TypeName(value)
 
 RemoveAt Index
 If Index = Count Then
 Add value
 Else
 Insert Index, value
 End If
 
End Property
Public Property Get NewEnum() As IUnknown
Attribute NewEnum.VB_Description = "Gets an enumerator that iterates through the List."
Attribute NewEnum.VB_UserMemId = -4
Attribute NewEnum.VB_MemberFlags = "40"
'Gets an enumerator that iterates through the List.
 
 Set NewEnum = this.Encapsulated.[_NewEnum]
End Property
Public Property Get Count() As Long
Attribute Count.VB_Description = "Gets the number of elements contained in the List."
'Gets the number of elements contained in the List.
 
 Count = this.Encapsulated.Count
End Property
Attribute Add.VB_Description = "Adds an object to the end of the List."
Attribute AddArray.VB_Description = "Adds the specified elements to the end of the List."
Attribute AddRange.VB_Description = "Adds the elements of the specified List to the end of the List."
Attribute AddValues.VB_Description = "Adds the specified elements to the end of the List."
Attribute Clear.VB_Description = "Removes all elements from the List."
Attribute Contains.VB_Description = "Determines whether an element is in the List."
Attribute First.VB_Description = "Returns the first element of the List."
Attribute GetRange.VB_Description = "Creates a copy of a range of elements in the source List."
Attribute IndexOf.VB_Description = "Searches for the specified object and returns the 1-based index of the first occurrence within the entire List."
 If Count = 0 Then IndexOf = -1: Exit Function
 For i = 1 To Count
 
 If isRef Then
 
 found = EquateReferenceTypes(value, Item(i))
 
 Else
 
 found = EquateValueTypes(value, Item(i))
 
 End If
 
 If found Then IndexOf = i: Exit Function
 
 Next
 
 IndexOf = -1
 
End Function
Public Sub Insert(ByVal Index As Long, value As Variant)
Attribute Insert.VB_Description = "Inserts an element into the List at the specified index."
'Inserts an element into the List at the specified index.
 
 Dim tmp As List
 Set tmp = GetRange(Index, Count)
 
 RemoveRange Index, Count
 
 Add value
 AddRange tmp
 
End Sub
Public Sub InsertArray(ByVal Index As Long, values() As Variant)
Attribute InsertArray.VB_Description = "Inserts the specified elements into the List at the specified index."
'Inserts the specified elements into the List at the specified index.
 
 Dim tmp As List
 Set tmp = GetRange(Index, Count)
 
 RemoveRange Index, Count
 
 AddArray values
 AddRange tmp
End Sub
Public Sub InsertRange(ByVal Index As Long, values As List)
Attribute InsertRange.VB_Description = "Inserts the specified elements into the List at the specified index."
'Inserts the specified elements into the List at the specified index.
 Dim tmp As List
 Set tmp = GetRange(Index, Count)
 
 RemoveRange Index, Count
 
 AddRange values
 AddRange tmp
 
End Sub
Public Sub InsertValues(ByVal Index As Long, ParamArray values())
Attribute InsertValues.VB_Description = "Inserts the specified elements into the List at the specified index."
'Inserts the specified elements into the List at the specified index.
 Dim valuesArray() As Variant
 valuesArray = values
 
 InsertArray Index, valuesArray
 
End Sub
Public Function IsSortable() As Boolean
Attribute IsSortable.VB_Description = "Determines whether the List can be sorted."
'Determines whether the List can be sorted.
 
 If Count = 0 Then Exit Function
 
 Dim firstItem As Variant
 If IsReferenceType Then
 Set firstItem = First
 Else
 firstItem = First
 End If
 
 IsSortable = IsNumeric(firstItem) _
 Or IsDate(firstItem) _
 Or this.ItemTypeName = "String" _
 Or IsComparable
 
End Function
Public Function IsTypeSafe(value As Variant) As Boolean
Attribute IsTypeSafe.VB_Description = "Determines whether a value can be safely added to the List."
'Determines whether a value can be safely added to the List.
'Returns true if the type of specified value matches the type of items already in the list,
'or it the type of specified value is a numeric type smaller than the type of items already in the list.
'This means a List<Long> can contain Integer values, but a List<Integer> cannot contain Long values.
 
 Dim result As Boolean
 
 'most common cases: this.ItemTypeName isn't yet defined, or matches TypeName(value):
 result = this.ItemTypeName = vbNullString Or this.ItemTypeName = TypeName(value)
 If result Then IsTypeSafe = result: Exit Function
 
 'all other cases demand more processing:
 IsTypeSafe = 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")
 
End Function
Public Function Last() As Variant
Attribute Last.VB_Description = "Returns the last element of the List."
'Returns the last element of the List.
 
 If Count = 0 Then Exit Function
 If IsReferenceType Then
 Set Last = Item(Count)
 Else
 Last = Item(Count)
 End If
End Function
Public Function LastIndexOf(value As Variant) As Long
Attribute LastIndexOf.VB_Description = "Searches for the specified object and returns the 1-based index of the last occurrence within the entire List."
'Searches for the specified object and returns the 1-based index of the last occurrence within the entire List.
 
 Dim found As Boolean
 Dim isRef As Boolean
 isRef = IsReferenceType
 
 LastIndexOf = -1
 If Count = 0 Then Exit Function
 Dim i As Long
 For i = 1 To Count
 
 If isRef Then
 
 found = EquateReferenceTypes(value, Item(i))
 
 Else
 
 found = EquateValueTypes(value, Item(i))
 
 End If
 
 If found Then LastIndexOf = i
 
 Next
 
End Function
Public Function Max() As Variant
Attribute Max.VB_Description = "Returns the maximum value in the List."
'Returns the maximum value in the List.
 
 Dim isRef As Boolean
 isRef = IsReferenceType
 
 Dim largest As Variant
 Dim isLarger As Boolean
 
 Dim i As Long
 For i = 1 To Count
 
 If isRef Then
 
 If IsEmpty(largest) Then Set largest = Item(i)
 isLarger = CompareReferenceTypes(Item(i), largest) > 0
 
 If isLarger Or IsEmpty(Max) Then
 Set largest = Item(i)
 Set Max = largest
 End If
 
 Else
 
 If IsEmpty(largest) Then largest = Item(i)
 isLarger = CompareValueTypes(Item(i), largest) > 0
 
 If isLarger Or IsEmpty(Max) Then
 largest = Item(i)
 Max = largest
 End If
 
 End If
 
 
 Next
End Function
Public Function Min() As Variant
Attribute Min.VB_Description = "Returns the minimum value in the List."
'Returns the minimum value in the List.
 
 Dim isRef As Boolean
 isRef = IsReferenceType
 
 Dim smallest As Variant
 Dim isSmaller As Boolean
 
 Dim i As Long
 For i = 1 To Count
 
 If isRef Then
 
 If IsEmpty(smallest) Then Set smallest = Item(i)
 isSmaller = CompareReferenceTypes(Item(i), smallest) < 0
 
 If isSmaller Or IsEmpty(Min) Then
 Set smallest = Item(i)
 Set Min = smallest
 End If
 
 Else
 
 If IsEmpty(smallest) Then smallest = Item(i)
 isSmaller = CompareValueTypes(Item(i), smallest) < 0
 
 If isSmaller Or IsEmpty(Min) Then
 smallest = Item(i)
 Min = smallest
 End If
 
 End If
 
 
 Next
 
End Function
Public Sub Reverse()
Attribute Reverse.VB_Description = "Reverses the order of the elements in the entire List."
'Reverses the order of the elements in the entire List.
 
 Dim tmp As New List
 Do Until Count = 0
 
 tmp.Add Item(Count)
 RemoveAt Count
 
 Loop
 
 AddRange tmp
 
End Sub
Public Sub Remove(ParamArray values())
Attribute Remove.VB_Description = "Removes the first occurrence of specified object(s) from the List."
'Removes the first occurrence of specified object(s) from the List.
 
 Dim i As Long
 Dim Index As Long
 
 For i = LBound(values) To UBound(values)
 
 Index = IndexOf(values(i))
 If Index <> -1 Then RemoveAt Index
 
 Next
End Sub
Public Sub RemoveAt(ByVal Index As Long)
Attribute RemoveAt.VB_Description = "Removes the element at the specified index of the List."
'Removes the element at the specified index of the List.
 
 this.Encapsulated.Remove Index
End Sub
Public Sub RemoveRange(ByVal Index As Long, ByVal valuesCount As Long)
Attribute RemoveRange.VB_Description = "Removes a range of elements from the List."
'Removes a range of elements from the List.
 
 Dim i As Long
 For i = Index To Index + valuesCount - 1
 
 RemoveAt Index
 
 Next
 
End Sub
Public Sub Sort()
Attribute Sort.VB_Description = "Sorts the elements in the entire List."
'Sorts the elements in the entire List.
 Dim tmp As List
 Dim minValue As Variant
 
 If Not IsSortable Then RaiseErrorMustImplementIComparable "Sort()"
 
 Dim isRef As Boolean
 isRef = IsReferenceType
 
 Set tmp = New List
 Do Until Count = 0
 
 If isRef Then
 
 Set minValue = Min
 
 Else
 
 minValue = Min
 
 End If
 
 tmp.Add minValue
 Remove minValue
 
 Loop
 
 AddRange tmp
 
End Sub
Public Sub SortDescending()
Attribute SortDescending.VB_Description = "Sorts the elements in the entire List, in descending order."
'Sorts the elements in the entire List, in descending order.
 
 Dim tmp As List
 Dim maxValue As Variant
 
 If Not IsSortable Then RaiseErrorMustImplementIComparable "SortDescending()"
 
 Dim isRef As Boolean
 isRef = IsReferenceType
 
 Set tmp = New List
 Do Until Count = 0
 
 If isRef Then
 Set maxValue = Max
 Else
 maxValue = Max
 End If
 
 tmp.Add maxValue
 Remove maxValue
 
 Loop
 
 AddRange tmp
 
End Sub
Public Function ToArray() As Variant()
Attribute ToArray.VB_Description = "Copies the elements of the List to a new array."
'Copies the elements of the List to a new array.
 
 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) = Item(i)
 Next
 Else
 For i = 1 To Count
 result(i) = Item(i)
 Next
 End If
 
 ToArray = result
 
End Function
Public Function ToString() As String
Attribute ToString.VB_Description = "Returns a string that represents the current List object."
'Returns a string that represents the current List object.
 
 ToString = StringFormat("{0}<{1}>", TypeName(Me), Coalesce(this.ItemTypeName, "Variant"))
End Function
VERSION 1.0 CLASS
BEGIN
 MultiUse = -1 'True
 Persistable = 0 'NotPersistable
 DataBindingBehavior = 0 'vbNone
 DataSourceBehavior = 0 'vbNone
 MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "IComparable"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
Public Function CompareTo(other As Variant) As Integer
Attribute CompareTo.VB_Description = "Compares the current instance with another object of the same type and returns an integer that indicates whether the current instance precedes, follows, or occurs in the same position in the sort order as the other object."
End Function
VERSION 1.0 CLASS
BEGIN
 MultiUse = -1 'True
 Persistable = 0 'NotPersistable
 DataBindingBehavior = 0 'vbNone
 DataSourceBehavior = 0 'vbNone
 MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "IEquatable"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
Public Function Equals(other As Variant) As Boolean
End Function
Attribute VB_Name = "List"
Private Type tList
 Encapsulated As Collection
 ItemTypeName As String
End Type
Private this As tList
Option Explicit
Private Function IsReferenceType() As Boolean
 If Count = 0 Then Exit Function
 IsReferenceType = IsObject(this.Encapsulated(1))
End Function
Private Function IsComparable() As Boolean
 If IsReferenceType Then
 IsComparable = TypeOf First Is IComparable
 End If
End Function
Private Function CompareReferenceTypes(value As Variant, other As Variant) As Integer
 
 Dim comparable As IComparable
 
 If IsComparable Then
 
 Set comparable = value
 CompareReferenceTypes = comparable.CompareTo(other)
 
 Else
 
 RaiseErrorMustImplementIComparable "CompareReferenceTypes()"
 
 End If
 
End Function
Private Function CompareValueTypes(value As Variant, other As Variant) As Integer
 
 If value < other Then
 
 CompareValueTypes = -1
 
 ElseIf value > other Then
 
 CompareValueTypes = 1
 
 End If
 
End Function
Private Function IsEquatable() As Boolean
 If IsReferenceType Then
 IsEquatable = TypeOf First Is IEquatable
 End If
End Function
Private Function EquateReferenceTypes(value As Variant, other As Variant) As Boolean
 
 Dim equatable As IEquatable
 If IsEquatable Then
 
 Set equatable = value
 EquateReferenceTypes = equatable.Equals(other)
 
 Else
 
 Debug.Print "WARNING: Reference type doesn't implement IEquatable, using reference equality."
 EquateReferenceTypes = (ObjPtr(value) = ObjPtr(other))
 
 End If
 
End Function
Private Function EquateValueTypes(value As Variant, other As Variant) As Boolean
 
 EquateValueTypes = (value = other)
End Function
Private Function ValidateItemType(value As Variant)
 
 If this.ItemTypeName = vbNullString Then this.ItemTypeName = TypeName(value)
 ValidateItemType = IsTypeSafe(value)
 
End Function
Private Sub RaiseErrorUnsafeType(member As String, suppliedType As String)
 Err.Raise 13, StringFormat("{0}.{1}", ToString, member), _
 StringFormat("Type Mismatch. Expected: '{0}', '{1}' was supplied.", this.ItemTypeName, suppliedType)
End Sub
Private Sub RaiseErrorMustImplementIComparable(member As String)
 Err.Raise 5, StringFormat("{0}.{1}", ToString, member), "Invalid operation: method requires a list of numeric, date or string values, or a list of objects implementing the IComparable interface."
End Sub
Private Sub Class_Initialize()
 Set this.Encapsulated = New Collection
End Sub
Private Sub Class_Terminate()
 Set this.Encapsulated = Nothing
End Sub
Public Property Get Item(ByVal Index As Long) As Variant
Attribute Item.VB_UserMemId = 0
'Gets the element at the specified index.
 
 If IsReferenceType Then
 Set Item = this.Encapsulated(Index)
 Else
 Item = this.Encapsulated(Index)
 End If
End Property
Public Property Let Item(ByVal Index As Long, ByVal value As Variant)
'Sets the element at the specified index.
 If Not IsTypeSafe(value) Then RaiseErrorUnsafeType "Item(Let)", TypeName(value)
 
 RemoveAt Index
 If Index = Count Then
 Add value
 Else
 Insert Index, value
 End If
 
End Property
Public Property Set Item(ByVal Index As Long, ByVal value As Variant)
'Sets the element at the specified index.
 
 If Not IsTypeSafe(value) Then RaiseErrorUnsafeType "Item(Set)", TypeName(value)
 
 RemoveAt Index
 If Index = Count Then
 Add value
 Else
 Insert Index, value
 End If
 
End Property
Public Property Get NewEnum() As IUnknown
Attribute NewEnum.VB_UserMemId = -4
Attribute NewEnum.VB_MemberFlags = "40"
'Gets an enumerator that iterates through the List.
 
 Set NewEnum = this.Encapsulated.[_NewEnum]
End Property
Public Property Get Count() As Long
 
 Count = this.Encapsulated.Count
End Property
 If Count = 0 Then IndexOf = -1: Exit Function
 For i = 1 To Count
 
 If isRef Then
 
 found = EquateReferenceTypes(value, Item(i))
 
 Else
 
 found = EquateValueTypes(value, Item(i))
 
 End If
 
 If found Then IndexOf = i: Exit Function
 
 Next
 
 IndexOf = -1
 
End Function
Public Sub Insert(ByVal Index As Long, value As Variant)
'Inserts an element into the List at the specified index.
 
 Dim tmp As List
 Set tmp = GetRange(Index, Count)
 
 RemoveRange Index, Count
 
 Add value
 AddRange tmp
 
End Sub
Public Sub InsertArray(ByVal Index As Long, values() As Variant)
'Inserts the specified elements into the List at the specified index.
 
 Dim tmp As List
 Set tmp = GetRange(Index, Count)
 
 RemoveRange Index, Count
 
 AddArray values
 AddRange tmp
End Sub
Public Sub InsertRange(ByVal Index As Long, values As List)
'Inserts the specified elements into the List at the specified index.
 Dim tmp As List
 Set tmp = GetRange(Index, Count)
 
 RemoveRange Index, Count
 
 AddRange values
 AddRange tmp
 
End Sub
Public Sub InsertValues(ByVal Index As Long, ParamArray values())
'Inserts the specified elements into the List at the specified index.
 Dim valuesArray() As Variant
 valuesArray = values
 
 InsertArray Index, valuesArray
 
End Sub
Public Function IsSortable() As Boolean
'Determines whether the List can be sorted.
 
 If Count = 0 Then Exit Function
 
 Dim firstItem As Variant
 If IsReferenceType Then
 Set firstItem = First
 Else
 firstItem = First
 End If
 
 IsSortable = IsNumeric(firstItem) _
 Or IsDate(firstItem) _
 Or this.ItemTypeName = "String" _
 Or IsComparable
 
End Function
Public Function IsTypeSafe(value As Variant) As Boolean
'Determines whether a value can be safely added to the List.
'Returns true if the type of specified value matches the type of items already in the list,
'or it the type of specified value is a numeric type smaller than the type of items already in the list.
'This means a List<Long> can contain Integer values, but a List<Integer> cannot contain Long values.
 
 Dim result As Boolean
 
 'most common cases: this.ItemTypeName isn't yet defined, or matches TypeName(value):
 result = this.ItemTypeName = vbNullString Or this.ItemTypeName = TypeName(value)
 If result Then IsTypeSafe = result: Exit Function
 
 'all other cases demand more processing:
 IsTypeSafe = 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")
 
End Function
Public Function Last() As Variant
'Returns the last element of the List.
 
 If Count = 0 Then Exit Function
 If IsReferenceType Then
 Set Last = Item(Count)
 Else
 Last = Item(Count)
 End If
End Function
Public Function LastIndexOf(value As Variant) As Long
'Searches for the specified object and returns the 1-based index of the last occurrence within the entire List.
 
 Dim found As Boolean
 Dim isRef As Boolean
 isRef = IsReferenceType
 
 LastIndexOf = -1
 If Count = 0 Then Exit Function
 Dim i As Long
 For i = 1 To Count
 
 If isRef Then
 
 found = EquateReferenceTypes(value, Item(i))
 
 Else
 
 found = EquateValueTypes(value, Item(i))
 
 End If
 
 If found Then LastIndexOf = i
 
 Next
 
End Function
Public Function Max() As Variant
'Returns the maximum value in the List.
 
 Dim isRef As Boolean
 isRef = IsReferenceType
 
 Dim largest As Variant
 Dim isLarger As Boolean
 
 Dim i As Long
 For i = 1 To Count
 
 If isRef Then
 
 If IsEmpty(largest) Then Set largest = Item(i)
 isLarger = CompareReferenceTypes(Item(i), largest) > 0
 
 If isLarger Or IsEmpty(Max) Then
 Set largest = Item(i)
 Set Max = largest
 End If
 
 Else
 
 If IsEmpty(largest) Then largest = Item(i)
 isLarger = CompareValueTypes(Item(i), largest) > 0
 
 If isLarger Or IsEmpty(Max) Then
 largest = Item(i)
 Max = largest
 End If
 
 End If
 
 
 Next
End Function
Public Function Min() As Variant
'Returns the minimum value in the List.
 
 Dim isRef As Boolean
 isRef = IsReferenceType
 
 Dim smallest As Variant
 Dim isSmaller As Boolean
 
 Dim i As Long
 For i = 1 To Count
 
 If isRef Then
 
 If IsEmpty(smallest) Then Set smallest = Item(i)
 isSmaller = CompareReferenceTypes(Item(i), smallest) < 0
 
 If isSmaller Or IsEmpty(Min) Then
 Set smallest = Item(i)
 Set Min = smallest
 End If
 
 Else
 
 If IsEmpty(smallest) Then smallest = Item(i)
 isSmaller = CompareValueTypes(Item(i), smallest) < 0
 
 If isSmaller Or IsEmpty(Min) Then
 smallest = Item(i)
 Min = smallest
 End If
 
 End If
 
 
 Next
 
End Function
Public Sub Reverse()
'Reverses the order of the elements in the entire List.
 
 Dim tmp As New List
 Do Until Count = 0
 
 tmp.Add Item(Count)
 RemoveAt Count
 
 Loop
 
 AddRange tmp
 
End Sub
Public Sub Remove(ParamArray values())
'Removes the first occurrence of specified object(s) from the List.
 
 Dim i As Long
 Dim Index As Long
 
 For i = LBound(values) To UBound(values)
 
 Index = IndexOf(values(i))
 If Index <> -1 Then RemoveAt Index
 
 Next
End Sub
Public Sub RemoveAt(ByVal Index As Long)
'Removes the element at the specified index of the List.
 
 this.Encapsulated.Remove Index
End Sub
Public Sub RemoveRange(ByVal Index As Long, ByVal valuesCount As Long)
'Removes a range of elements from the List.
 
 Dim i As Long
 For i = Index To Index + valuesCount - 1
 
 RemoveAt Index
 
 Next
 
End Sub
Public Sub Sort()
'Sorts the elements in the entire List.
 Dim tmp As List
 Dim minValue As Variant
 
 If Not IsSortable Then RaiseErrorMustImplementIComparable "Sort()"
 
 Dim isRef As Boolean
 isRef = IsReferenceType
 
 Set tmp = New List
 Do Until Count = 0
 
 If isRef Then
 
 Set minValue = Min
 
 Else
 
 minValue = Min
 
 End If
 
 tmp.Add minValue
 Remove minValue
 
 Loop
 
 AddRange tmp
 
End Sub
Public Sub SortDescending()
'Sorts the elements in the entire List, in descending order.
 
 Dim tmp As List
 Dim maxValue As Variant
 
 If Not IsSortable Then RaiseErrorMustImplementIComparable "SortDescending()"
 
 Dim isRef As Boolean
 isRef = IsReferenceType
 
 Set tmp = New List
 Do Until Count = 0
 
 If isRef Then
 Set maxValue = Max
 Else
 maxValue = Max
 End If
 
 tmp.Add maxValue
 Remove maxValue
 
 Loop
 
 AddRange tmp
 
End Sub
Public Function ToArray() As Variant()
'Copies the elements of the List to a new array.
 
 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) = Item(i)
 Next
 Else
 For i = 1 To Count
 result(i) = Item(i)
 Next
 End If
 
 ToArray = result
 
End Function
Public Function ToString() As String
'Returns a string that represents the current List object.
 
 ToString = StringFormat("{0}<{1}>", TypeName(Me), Coalesce(this.ItemTypeName, "Variant"))
End Function

IComparable:

Option Explicit
Public Function CompareTo(other As Variant) As Integer
End Function

IEquatable:

Option Explicit
Public Function Equals(other As Variant) As Boolean
End Function

fixed typo
Source Link
Mathieu Guindon
  • 75.5k
  • 18
  • 194
  • 467
Loading
edited title
Link
Mathieu Guindon
  • 75.5k
  • 18
  • 194
  • 467
Loading
fixed syntax highlighting
Source Link
Mathieu Guindon
  • 75.5k
  • 18
  • 194
  • 467
Loading
broke down single code block into smaller chunks, added C# tag
Source Link
Mathieu Guindon
  • 75.5k
  • 18
  • 194
  • 467
Loading
fixed typos, removed redundant error-handling
Source Link
Mathieu Guindon
  • 75.5k
  • 18
  • 194
  • 467
Loading
added 9705 characters in body
Source Link
Mathieu Guindon
  • 75.5k
  • 18
  • 194
  • 467
Loading
Post Undeleted by Mathieu Guindon
Post Deleted by Mathieu Guindon
Fixed value comparison for reference types
Source Link
Mathieu Guindon
  • 75.5k
  • 18
  • 194
  • 467
Loading
Fixed bugs with object variables as list content, added min/max/sort functionality and IComparer interface.
Source Link
Mathieu Guindon
  • 75.5k
  • 18
  • 194
  • 467
Loading
added tags; edited tags
Link
Mathieu Guindon
  • 75.5k
  • 18
  • 194
  • 467
Loading
Source Link
Mathieu Guindon
  • 75.5k
  • 18
  • 194
  • 467
Loading
lang-vb

AltStyle によって変換されたページ (->オリジナル) /