Тема: VBScript: эмуляция коллекции (имитация Scripting.Dictionary)
Иногда в коде требуется создать коллекцию без использования дополнительных компонентов (таких, как Scripting.Dictionary). Например, если Internet Explorer выдаёт сообщение о загрузке Activex. Предлагается класс для решения этой задачи:
'Класс коллекции
'Методы
'Add Добавить элемент
'Remove Удалить элемент
'RemoveAll Удалить все элементы
''Свойства
'Item Элемент по ключу
'Items Коллекция элементов
'Key Ключ по индексу
'Keys Коллекция ключей
'Count Количество элементов
'Функции
'Exists Проверить существование элемента по ключу
'// Пример
Dim Collection
Set Collection = New clsCollection
Collection("элемент 1") = "тестовая строка"
Collection("элемент 2") = 12345
Set Collection("элемент 3") = CreateObject("Scripting.FileSystemObject")
Collection(3) = "1"
Collection(4) = Array("1","2","3")
Dim ret, Key, Item
For Each Key in Collection.Keys
If IsObject(Collection(Key)) Then
ret = ret & Key & "=" & TypeName(Collection(Key)) & " [Object]" & vbCrlf
Else
if isArray(Collection(Key)) Then
ret = ret & Key & "=" & " [Array]" & vbCrlf
Else
ret = ret & Key & "=" & Collection(Key) & " [" & TypeName(Collection(Key)) & "]" & vbCrlf
End if
End if
Next
msgbox ret
'// Класс коллекции
Class clsCollection
Private KeysArray, ItemsArray, ElementCount, ElementIndex, KeyIndex
Private Sub Class_Initialize
RemoveAll
End Sub
Public Default Property Get Item(ByVal Key)
ElementIndex = GetKeyIndex(Key)
if ElementIndex < 0 Then Exit Property
if IsObject(ItemsArray(ElementIndex)) Then
Set Item = ItemsArray(ElementIndex)
Else
Item = ItemsArray(ElementIndex)
End if
End Property
Public Property Set Item(ByVal Key, Value)
Item(Key) = Value
End Property
Public Property Let Item(ByVal Key, Value)
ElementIndex = GetKeyIndex(Key)
if ElementIndex => 0 Then
KeysArray(ElementIndex) = Key
if IsObject(Value) Then
Set ItemsArray(ElementIndex) = Value
Else
ItemsArray(ElementIndex) = Value
End if
Else
Redim Preserve ItemsArray(ElementCount)
Redim Preserve KeysArray(ElementCount)
KeysArray(ElementCount) = Key
if IsObject(Value) Then
Set ItemsArray(ElementCount) = Value
Else
ItemsArray(ElementCount) = Value
End if
ElementCount = ElementCount + 1
End if
End Property
Function Add(ByVal Key, Value)
if GetKeyIndex(Key) => 0 Then
Err.Raise vbObjectError + 1,,"Элемент уже существует в коллекции"
Else
Item(Key) = Value
End if
End Function
Function Remove(ByVal Key)
Dim KeyIndex
KeyIndex = GetKeyIndex(Key)
if KeyIndex < 0 Then Exit Function
For ElementIndex = KeyIndex to ElementCount - 2
ItemsArray(ElementIndex) = ItemsArray(ElementIndex+1)
KeysArray(ElementIndex) = KeysArray(ElementIndex+1)
Next
Redim Preserve ItemsArray(ElementCount - 2)
Redim Preserve KeysArray(ElementCount - 2)
ElementCount = ElementCount - 1
End Function
Public Property Get Key(ByVal Index)
if Index <= Ubound(KeysArray) Then
Key = KeysArray(Index)
End if
End Property
Private Function GetKeyIndex(ByVal Key)
Key = LCase(Key)
GetKeyIndex = -1
For ElementIndex = 0 To ElementCount - 1
if LCase(KeysArray(ElementIndex)) = Key Then
GetKeyIndex = ElementIndex
Exit For
End if
Next
End Function
Public Property Get Items
Items = ItemsArray
End Property
Public Property Get Keys
Keys = KeysArray
End Property
Function RemoveAll
ItemsArray = Array()
KeysArray = Array()
ElementCount = 0
End Function
Function Exists(ByVal Key)
if GetKeyIndex(Key) => 0 Then
Exists = True
Else
Exists = False
End if
End Function
Public Property Get Count
Count = ElementCount
End Property
End ClassАвтор идеи - Xameleon.
В названии ветки всегда должен быть указан язык программирования или среда исполнения скрипта, если это возможно.

