Skip to content

Commit

Permalink
Big performance improvements
Browse files Browse the repository at this point in the history
  • Loading branch information
@timhall
timhall committed Sep 16, 2014
1 parent afe1a5c commit 735abc5
Show file tree
Hide file tree
Showing 3 changed files with 278 additions and 81 deletions.
273 changes: 194 additions & 79 deletions Dictionary.cls
View file
Original file line number Diff line number Diff line change
Expand Up @@ -8,7 +8,7 @@ Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
''
' Dictionary v1.0.3
' Dictionary v1.0.4
' (c) Tim Hall - https://github.com/timhall/VBA-Dictionary
'
' Drop-in replacement for Scripting.Dictionary on Mac
Expand All @@ -23,8 +23,8 @@ Option Explicit
' Constants and Private Variables
' --------------------------------------------- '

Private pKeys As Collection
Private pItems As Collection
' Store 0: Index, 1: Key, 2: Value
Private pKeyValues As Collection
Private pCompareMode As CompareMethod

' --------------------------------------------- '
Expand Down Expand Up @@ -55,37 +55,45 @@ Public Property Let CompareMode(Value As CompareMethod)
End Property

Public Property Get Count() As Long
Count = pKeys.Count
Count = pKeyValues.Count
End Property

Public Property Get Item(Key As Variant) As Variant
Attribute Item.VB_UserMemId = 0
Dim Index As Long
Index = IndexOfKey(Key)
Dim KeyValue As Variant
KeyValue = GetKeyValue(Key)

If Index >= 0 Then
If IsObject(pItems(Index)) Then
Set Item = pItems(Index)
If Not IsEmpty(KeyValue) Then
If IsObject(KeyValue(2)) Then
Set Item = KeyValue(2)
Else
Item = pItems(Index)
Item = KeyValue(2)
End If
Else
' Not found -> Returns Empty
End If
End Property
Public Property Let Item(Key As Variant, Value As Variant)
AddItem Key, Value
If Me.Exists(Key) Then
ReplaceKeyValue GetKeyValue(Key), Key, Value
Else
AddKeyValue Key, Value
End If
End Property
Public Property Set Item(Key As Variant, Value As Variant)
AddItem Key, Value
If Me.Exists(Key) Then
ReplaceKeyValue GetKeyValue(Key), Key, Value
Else
AddKeyValue Key, Value
End If
End Property

Public Property Let Key(Previous As Variant, Updated As Variant)
Dim Index As Long
Index = IndexOfKey(Previous)
Dim KeyValue As Variant
KeyValue = GetKeyValue(Previous)

If Index >= 0 Then
ReplaceItemInCollection pKeys, CStr(Updated), Index
If Not IsEmpty(KeyValue) Then
ReplaceKeyValue KeyValue, Updated, KeyValue(2)
End If
End Property

Expand All @@ -101,8 +109,7 @@ End Property
' --------------------------------------------- '
Public Sub Add(Key As Variant, Item As Variant)
If Not Me.Exists(Key) Then
pKeys.Add CStr(Key)
pItems.Add Item
AddKeyValue Key, Item
Else
' This key is already associated with an element of this collection
Err.Raise 457
Expand All @@ -116,7 +123,7 @@ End Sub
' @return {Boolean}
' --------------------------------------------- '
Public Function Exists(Key As Variant) As Boolean
Exists = IndexOfKey(Key) >= 0
Exists = Not IsEmpty(GetKeyValue(Key))
End Function

''
Expand All @@ -125,7 +132,23 @@ End Function
' @return {Variant}
' --------------------------------------------- '
Public Function Items() As Variant
Items = CollectionToArray(pItems)
Dim Arr As Variant

If pKeyValues.Count > 0 Then
Dim i As Long
ReDim Arr(pKeyValues.Count - 1)
For i = 1 To pKeyValues.Count
If IsObject(pKeyValues(i)(2)) Then
Set Arr(i - 1) = pKeyValues(i)(2)
Else
Arr(i - 1) = pKeyValues(i)(2)
End If
Next i
Else
Arr = Array()
End If

Items = Arr
End Function

''
Expand All @@ -134,7 +157,19 @@ End Function
' @return {Variant}
' --------------------------------------------- '
Public Function Keys() As Variant
Keys = CollectionToArray(pKeys)
Dim Arr As Variant

If pKeyValues.Count > 0 Then
Dim i As Long
ReDim Arr(pKeyValues.Count - 1)
For i = 1 To pKeyValues.Count
Arr(i - 1) = pKeyValues(i)(1)
Next i
Else
Arr = Array()
End If

Keys = Arr
End Function

''
Expand All @@ -143,12 +178,11 @@ End Function
' @param {Variant} Key
' --------------------------------------------- '
Public Sub Remove(Key As Variant)
Dim Index As Long
Index = IndexOfKey(Key)
Dim KeyValue As Variant
KeyValue = GetKeyValue(Key)

If Index > -1 Then
pKeys.Remove Index
pItems.Remove Index
If Not IsEmpty(KeyValue) Then
RemoveKeyValue KeyValue
Else
' Application-defined or object-defined error
Err.Raise 32811
Expand All @@ -159,82 +193,163 @@ End Sub
' Remove all items
' --------------------------------------------- '
Public Sub RemoveAll()
Set pKeys = New Collection
Set pItems = New Collection
Set pKeyValues = New Collection
End Sub

' ============================================= '
' Private Functions
' ============================================= '

Private Function IndexOfKey(Key As Variant) As Long
Dim i As Long
Key = CStr(Key)

For i = 1 To pKeys.Count
If VBA.StrComp(pKeys(i), Key, Me.CompareMode) = 0 Then
IndexOfKey = i
Exit Function
End If
Next i

' Not found
IndexOfKey = -1
Private Function GetKeyValue(Key As Variant) As Variant
On Error Resume Next
GetKeyValue = pKeyValues(GetFormattedKey(Key))
End Function

Private Sub AddItem(Key As Variant, Item As Variant)
Private Sub AddKeyValue(Key As Variant, Value As Variant)
Dim FormattedKey As String
FormattedKey = GetFormattedKey(Key)
pKeyValues.Add Array(pKeyValues.Count + 1, FormattedKey, Value), FormattedKey
End Sub

Private Sub ReplaceKeyValue(KeyValue As Variant, Key As Variant, Value As Variant)
' Remove previous KeyValue
RemoveKeyValue KeyValue

' Add new key and value
Dim Index As Long
Index = IndexOfKey(Key)
Dim NewKeyValue As Variant
Index = KeyValue(0)
NewKeyValue = Array(Index, GetFormattedKey(Key), Value)

If Index >= 0 Then
ReplaceItemInCollection pItems, Item, Index
' Add updated key value back to KeyValues
If pKeyValues.Count = 0 Then
pKeyValues.Add NewKeyValue, CStr(Key)
ElseIf Index > pKeyValues.Count Then
pKeyValues.Add NewKeyValue, CStr(Key), After:=Index - 1
Else
pKeys.Add CStr(Key)
pItems.Add Item
pKeyValues.Add NewKeyValue, CStr(Key), Before:=Index
End If
End Sub

Private Sub ReplaceItemInCollection(ByRef Coll As Collection, Item As Variant, Index As Long)
If Index >= 1 And Index <= Coll.Count Then
Coll.Remove Index

If Coll.Count = 0 Then
Coll.Add Item
ElseIf Index > Coll.Count Then
Coll.Add Item, After:=Index - 1
Else
Coll.Add Item, Before:=Index
End If
End If
Private Sub RemoveKeyValue(KeyValue As Variant)
pKeyValues.Remove KeyValue(0)
End Sub

Private Function CollectionToArray(Coll As Collection) As Variant
Dim Arr As Variant
Dim i As Long

' Collection is 1-based / Variant is 0-based
If Coll.Count > 0 Then
ReDim Arr(Coll.Count - 1)
For i = 1 To Coll.Count
If IsObject(Coll(i)) Then
Set Arr(i - 1) = Coll(i)
Else
Arr(i - 1) = Coll(i)
Private Function GetFormattedKey(Key As Variant) As String
GetFormattedKey = CStr(Key)
If Me.CompareMode = CompareMethod.TextCompare Then
GetFormattedKey = UCase(GetFormattedKey)
ElseIf Me.CompareMode = CompareMethod.BinaryCompare Then
' Collection does not have method of setting key comparison
' So case-sensitive keys aren't supported by default
' -> Approach: Append lowercase characters to original key
' AbC -> AbC__b, abc -> abc__abc, ABC -> ABC
Dim Lowercase As String
Lowercase = ""

Dim i As Integer
Dim Ascii As Integer
Dim Char As String
For i = 1 To Len(GetFormattedKey)
Char = Mid$(GetFormattedKey, i, 1)
Ascii = Asc(Char)
If Ascii >= 97 And Ascii <= 122 Then
Lowercase = Lowercase & Char
End If
Next i
Else
Arr = Array()

If Lowercase <> "" Then
GetFormattedKey = GetFormattedKey & "__" & Lowercase
End If
End If

CollectionToArray = Arr
End Function

'Private Function GetKey(KeyValue As Variant) As String
' If Not IsEmpty(KeyValue) Then
' GetKey = KeyValue(0)
' End If
'End Function
'Private Function GetValue(KeyValue As Variant) As Variant
' If Not IsEmpty(KeyValue) Then
' If IsObject(KeyValue(1)) Then
' Set GetValue = KeyValue(1)
' Else
' GetValue = KeyValue(1)
' End If
' End If
'End Function
'Private Function GetIndex(KeyValue As Variant) As Long
' If Not IsEmpty(KeyValue) Then
' GetIndex = KeyValue(2)
' End If
'End Function

'Private Function IndexOfKey(Key As Variant) As Long
' Dim i As Long
' Key = CStr(Key)
'
' For i = 1 To pKeys.Count
' If VBA.StrComp(pKeys(i), Key, Me.CompareMode) = 0 Then
' IndexOfKey = i
' Exit Function
' End If
' Next i
'
' ' Not found
' IndexOfKey = -1
'End Function
'
'Private Sub AddItem(Key As Variant, Item As Variant)
' Dim Index As Long
' Index = IndexOfKey(Key)
'
' If Index >= 0 Then
' ReplaceItemInCollection pItems, Item, Index
' Else
' pKeys.Add CStr(Key)
' pItems.Add Item
' End If
'End Sub
'
'Private Sub ReplaceItemInCollection(ByRef Coll As Collection, Item As Variant, Index As Long)
' If Index >= 1 And Index <= Coll.Count Then
' Coll.Remove Index
'
' If Coll.Count = 0 Then
' Coll.Add Item
' ElseIf Index > Coll.Count Then
' Coll.Add Item, After:=Index - 1
' Else
' Coll.Add Item, Before:=Index
' End If
' End If
'End Sub
'
'Private Function CollectionToArray(Coll As Collection) As Variant
' Dim Arr As Variant
' Dim i As Long
'
' ' Collection is 1-based / Variant is 0-based
' If Coll.Count > 0 Then
' ReDim Arr(Coll.Count - 1)
' For i = 1 To Coll.Count
' If IsObject(Coll(i)) Then
' Set Arr(i - 1) = Coll(i)
' Else
' Arr(i - 1) = Coll(i)
' End If
' Next i
' Else
' Arr = Array()
' End If
'
' CollectionToArray = Arr
'End Function

Private Sub Class_Initialize()
Set pKeys = New Collection
Set pItems = New Collection
Set pKeyValues = New Collection
End Sub

Private Sub Class_Terminate()
Set pKeys = Nothing
Set pItems = Nothing
Set pKeyValues = Nothing
End Sub
Loading

0 comments on commit 735abc5

Please sign in to comment.