类模块

1
''
2
' Dictionary v1.2.0
3
' (c) Tim Hall - https://github.com/timhall/VBA-Dictionary
4
'
5
' Drop-in replacement for Scripting.Dictionary on Mac
6
'
7
' @author: [email protected]
8
' @license: MIT (http://www.opensource.org/licenses/mit-license.php
9
'
10
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ '
11
Option Explicit
12

13
' --------------------------------------------- '
14
' Constants and Private Variables
15
' --------------------------------------------- '
16

17
#Const UseScriptingDictionaryIfAvailable = True
18

19
#If Mac Or Not UseScriptingDictionaryIfAvailable Then
20

21
    ' KeyValue 0: FormattedKey, 1: OriginalKey, 2: Value
22
    Private pKeyValues As Collection
23
    Private pKeys() As Variant
24
    Private pItems() As Variant
25
    Private pCompareMode As CompareMethod
26

27
#Else
28

29
    Private pDictionary As Object
30

31
#End If
32

33
' --------------------------------------------- '
34
' Types
35
' --------------------------------------------- '
36

37
Public Enum CompareMethod
38
    BinaryCompare = vbBinaryCompare
39
    TextCompare = vbTextCompare
40
    DatabaseCompare = vbDatabaseCompare
41
End Enum
42

43
' --------------------------------------------- '
44
' Properties
45
' --------------------------------------------- '
46

47
Public Property Get CompareMode() As CompareMethod
48
    #If Mac Or Not UseScriptingDictionaryIfAvailable Then
49
        CompareMode = pCompareMode
50
    #Else
51
        CompareMode = pDictionary.CompareMode
52
    #End If
53
End Property
54
Public Property Let CompareMode(Value As CompareMethod)
55
    #If Mac Or Not UseScriptingDictionaryIfAvailable Then
56
        If Me.Count > 0 Then
57
            ' Can't change CompareMode for Dictionary that contains data
58
            ' http://msdn.microsoft.com/en-us/library/office/gg278481(v=office.15).aspx
59
            ERR.Raise 5 ' Invalid procedure call or argument
60
        End If
61

62
        pCompareMode = Value
63
    #Else
64
        pDictionary.CompareMode = Value
65
    #End If
66
End Property
67

68
Public Property Get Count() As Long
69
    #If Mac Or Not UseScriptingDictionaryIfAvailable Then
70
        Count = pKeyValues.Count
71
    #Else
72
        Count = pDictionary.Count
73
    #End If
74
End Property
75

76
Public Property Get Item(Key As Variant) As Variant
77
    #If Mac Or Not UseScriptingDictionaryIfAvailable Then
78
        Dim KeyValue As Variant
79
        KeyValue = GetKeyValue(Key)
80

81
        If Not IsEmpty(KeyValue) Then
82
            If IsObject(KeyValue(2)) Then
83
                Set Item = KeyValue(2)
84
            Else
85
                Item = KeyValue(2)
86
            End If
87
        Else
88
            ' Not found -> Returns Empty
89
        End If
90
    #Else
91
        If IsObject(pDictionary.Item(Key)) Then
92
            Set Item = pDictionary.Item(Key)
93
        Else
94
            Item = pDictionary.Item(Key)
95
        End If
96
    #End If
97
End Property
98
Public Property Let Item(Key As Variant, Value As Variant)
99
    #If Mac Or Not UseScriptingDictionaryIfAvailable Then
100
        If Me.Exists(Key) Then
101
            ReplaceKeyValue GetKeyValue(Key), Key, Value
102
        Else
103
            AddKeyValue Key, Value
104
        End If
105
    #Else
106
        pDictionary.Item(Key) = Value
107
    #End If
108
End Property
109
Public Property Set Item(Key As Variant, Value As Variant)
110
    #If Mac Or Not UseScriptingDictionaryIfAvailable Then
111
        If Me.Exists(Key) Then
112
            ReplaceKeyValue GetKeyValue(Key), Key, Value
113
        Else
114
            AddKeyValue Key, Value
115
        End If
116
    #Else
117
        Set pDictionary.Item(Key) = Value
118
    #End If
119
End Property
120

121
Public Property Let Key(Previous As Variant, Updated As Variant)
122
    #If Mac Or Not UseScriptingDictionaryIfAvailable Then
123
        Dim KeyValue As Variant
124
        KeyValue = GetKeyValue(Previous)
125

126
        If Not IsEmpty(KeyValue) Then
127
            ReplaceKeyValue KeyValue, Updated, KeyValue(2)
128
        End If
129
    #Else
130
        pDictionary.Key(Previous) = Updated
131
    #End If
132
End Property
133

134
' ============================================= '
135
' Public Methods
136
' ============================================= '
137

138
''
139
' Add an item with the given key
140
'
141
' @param {Variant} Key
142
' @param {Variant} Item
143
' --------------------------------------------- '
144
Public Sub Add(Key As Variant, Item As Variant)
145
    #If Mac Or Not UseScriptingDictionaryIfAvailable Then
146
        If Not Me.Exists(Key) Then
147
            AddKeyValue Key, Item
148
        Else
149
            ' This key is already associated with an element of this collection
150
            ERR.Raise 457
151
        End If
152
    #Else
153
        pDictionary.Add Key, Item
154
    #End If
155
End Sub
156

157
''
158
' Check if an item exists for the given key
159
'
160
' @param {Variant} Key
161
' @return {Boolean}
162
' --------------------------------------------- '
163
Public Function Exists(Key As Variant) As Boolean
164
    #If Mac Or Not UseScriptingDictionaryIfAvailable Then
165
        Exists = Not IsEmpty(GetKeyValue(Key))
166
    #Else
167
        Exists = pDictionary.Exists(Key)
168
    #End If
169
End Function
170

171
''
172
' Get an array of all items
173
'
174
' @return {Variant}
175
' --------------------------------------------- '
176
Public Function Items() As Variant
177
    #If Mac Or Not UseScriptingDictionaryIfAvailable Then
178
        If Me.Count > 0 Then
179
            Items = pItems
180
        Else
181
            ' Split("") creates initialized empty array that matches Dictionary Keys and Items
182
            Items = Split("")
183
        End If
184
    #Else
185
        Items = pDictionary.Items
186
    #End If
187
End Function
188

189
''
190
' Get an array of all keys
191
'
192
' @return {Variant}
193
' --------------------------------------------- '
194
Public Function Keys() As Variant
195
    #If Mac Or Not UseScriptingDictionaryIfAvailable Then
196
        If Me.Count > 0 Then
197
            Keys = pKeys
198
        Else
199
            ' Split("") creates initialized empty array that matches Dictionary Keys and Items
200
            Keys = Split("")
201
        End If
202
    #Else
203
        Keys = pDictionary.Keys
204
    #End If
205
End Function
206

207
''
208
' Remove an item for the given key
209
'
210
' @param {Variant} Key
211
' --------------------------------------------- '
212
Public Sub Remove(Key As Variant)
213
    #If Mac Or Not UseScriptingDictionaryIfAvailable Then
214
        Dim KeyValue As Variant
215
        KeyValue = GetKeyValue(Key)
216

217
        If Not IsEmpty(KeyValue) Then
218
            RemoveKeyValue KeyValue
219
        Else
220
            ' Application-defined or object-defined error
221
            ERR.Raise 32811
222
        End If
223
    #Else
224
        pDictionary.Remove Key
225
    #End If
226
End Sub
227

228
''
229
' Remove all items
230
' --------------------------------------------- '
231
Public Sub RemoveAll()
232
    #If Mac Or Not UseScriptingDictionaryIfAvailable Then
233
        Set pKeyValues = New Collection
234

235
        Erase pKeys
236
        Erase pItems
237
    #Else
238
        pDictionary.RemoveAll
239
    #End If
240
End Sub
241

242
' ============================================= '
243
' Private Functions
244
' ============================================= '
245

246
#If Mac Or Not UseScriptingDictionaryIfAvailable Then
247

248
    Private Function GetKeyValue(Key As Variant) As Variant
249
        On Error Resume Next
250
        GetKeyValue = pKeyValues(GetFormattedKey(Key))
251
        ERR.Clear
252
    End Function
253

254
    Private Sub AddKeyValue(Key As Variant, Value As Variant, Optional Index As Long = -1)
255
        If Me.Count = 0 Then
256
            ReDim pKeys(0 To 0)
257
            ReDim pItems(0 To 0)
258
        Else
259
            ReDim Preserve pKeys(0 To UBound(pKeys) + 1)
260
            ReDim Preserve pItems(0 To UBound(pItems) + 1)
261
        End If
262

263
        Dim FormattedKey As String
264
        FormattedKey = GetFormattedKey(Key)
265

266
        If Index > 0 And Index <= pKeyValues.Count Then
267
            Dim i As Long
268
            For i = UBound(pKeys) To Index Step -1
269
                pKeys(i) = pKeys(i - 1)
270
                If IsObject(pItems(i - 1)) Then
271
                    Set pItems(i) = pItems(i - 1)
272
                Else
273
                    pItems(i) = pItems(i - 1)
274
                End If
275
            Next i
276

277
            pKeys(Index - 1) = Key
278
            If IsObject(Value) Then
279
                Set pItems(Index - 1) = Value
280
            Else
281
                pItems(Index - 1) = Value
282
            End If
283

284
            pKeyValues.Add Array(FormattedKey, Key, Value), FormattedKey, before:=Index
285
        Else
286
            pKeys(UBound(pKeys)) = Key
287
            If IsObject(Value) Then
288
                Set pItems(UBound(pItems)) = Value
289
            Else
290
                pItems(UBound(pItems)) = Value
291
            End If
292

293
            pKeyValues.Add Array(FormattedKey, Key, Value), FormattedKey
294
        End If
295
    End Sub
296

297
    Private Sub ReplaceKeyValue(KeyValue As Variant, Key As Variant, Value As Variant)
298
        Dim Index As Long
299
        Dim i As Integer
300

301
        For i = 0 To UBound(pKeys)
302
            If pKeys(i) = KeyValue(1) Then
303
                Index = i + 1
304
                Exit For
305
            End If
306
        Next i
307

308
        ' Remove existing value
309
        RemoveKeyValue KeyValue, Index
310

311
        ' Add new key value back
312
        AddKeyValue Key, Value, Index
313
    End Sub
314

315
    Private Sub RemoveKeyValue(KeyValue As Variant, Optional ByVal Index As Long = -1)
316
        Dim i As Long
317
        If Index = -1 Then
318
            For i = 0 To UBound(pKeys)
319
                If pKeys(i) = KeyValue(1) Then
320
                    Index = i
321
                End If
322
            Next i
323
        Else
324
            Index = Index - 1
325
        End If
326

327
        If Index >= 0 And Index <= UBound(pKeys) Then
328
            For i = Index To UBound(pKeys) - 1
329
                pKeys(i) = pKeys(i + 1)
330

331
                If IsObject(pItems(i + 1)) Then
332
                    Set pItems(i) = pItems(i + 1)
333
                Else
334
                    pItems(i) = pItems(i + 1)
335
                End If
336
            Next i
337

338
            If UBound(pKeys) = 0 Then
339
                Erase pKeys
340
                Erase pItems
341
            Else
342
                ReDim Preserve pKeys(0 To UBound(pKeys) - 1)
343
                ReDim Preserve pItems(0 To UBound(pItems) - 1)
344
            End If
345
        End If
346

347
        pKeyValues.Remove KeyValue(0)
348
    End Sub
349

350
    Private Function GetFormattedKey(Key As Variant) As String
351
        GetFormattedKey = CStr(Key)
352
        If Me.CompareMode = CompareMethod.BinaryCompare Then
353
            ' Collection does not have method of setting key comparison
354
            ' So case-sensitive keys aren't supported by default
355
            ' -> Approach: Append lowercase characters to original key
356
            '    AbC -> AbC__b, abc -> abc__abc, ABC -> ABC
357
            '    Won't work in very strange cases, but should work for now
358
            '    AbBb -> AbBb__bb matches AbbB -> AbbB__bb
359
            Dim Lowercase As String
360
            Lowercase = ""
361

362
            Dim i As Integer
363
            Dim Ascii As Integer
364
            Dim Char As String
365
            For i = 1 To Len(GetFormattedKey)
366
                Char = VBA.Mid$(GetFormattedKey, i, 1)
367
                Ascii = Asc(Char)
368
                If Ascii >= 97 And Ascii <= 122 Then
369
                    Lowercase = Lowercase & Char
370
                End If
371
            Next i
372

373
            If Lowercase <> "" Then
374
                GetFormattedKey = GetFormattedKey & "__" & Lowercase
375
            End If
376
        End If
377
    End Function
378

379
#End If
380

381
Private Sub Class_Initialize()
382
    #If Mac Or Not UseScriptingDictionaryIfAvailable Then
383
        Set pKeyValues = New Collection
384

385
        Erase pKeys
386
        Erase pItems
387
    #Else
388
        Set pDictionary = CreateObject("Scripting.Dictionary")
389
    #End If
390
End Sub
391

392
Private Sub Class_Terminate()
393
    #If Mac Or Not UseScriptingDictionaryIfAvailable Then
394
        Set pKeyValues = Nothing
395
    #Else
396
        Set pDictionary = Nothing
397
    #End If
398
End Sub