VBA VBS HashTable Queue Stack Class

変更履歴

VBA版

Hash Table Class

Option Explicit
' Ver 20190223
'ClassName clsHashTable
Private Hashtable
'[|:---------VBA Hash Class---------------------:|]
Private Sub Class_Initialize()
Set Hashtable = CreateObject("System.Collections.Hashtable")
End Sub
Function AddHashTbl(strkey, Value)
If IsNull(strkey) Then AddHashTbl = False: Exit Function
If isContainsKey(strkey) Then AddHashTbl = False: Exit Function
On Error Resume Next
Hashtable.Add strkey, Value
If Err.Number = 0 Then
AddHashTbl = True
Exit Function
Else
Debug.Print "AddHashTbl ", Err.Number, Err.Description
AddHashTbl = False
End If
End Function
'[|:---------VBA Hash Class---------------------:|]
Function isContainsKeyAndValue(strkey, Value)
isContainsKeyAndValue = Hashtable.Contains(strkey, Value)
End Function
Function isContainsKey(strkey)
If Hashtable.containskey(strkey) Then isContainsKey = True Else isContainsKey = False
End Function
'[|:---------VBA Hash Class---------------------:|]
Function isContainsValue(Value)
If Hashtable.Containsvalue(Value) Then isContainsValue = True Else isContainsValue = False
End Function
'[|:---------VBA Hash Class---------------------:|]
Function isKeyEquals(objValue, strHashTablekey)
'既にHashtableに存在しているKeyにValueがあるか
If Hashtable.containskey(strHashTablekey) Then
isKeyEquals = Hashtable.keyEquals(objValue)
Else
isKeyEquals = False
End If
End Function
'[|:---------VBA Hash Class---------------------:|]
Function rtnValueofKey(strkey)
rtnValueofKey = Hashtable.key(strkey)
End Function
'[|:---------VBA Hash Class---------------------:|]
Function rtnHashTable_Items_count()
rtnHashTable_Items_count = Hashtable.Count
End Function
'[|:---------VBA Hash Class---------------------:|]
Function HashTableRemoveKey(strkey)
On Error Resume Next
If Hashtable.containskey(strkey) Then
Hashtable.Remove (strkey)
HashTableRemoveKey = True
End If
On Error GoTo 0
If Err.Number <> 0 Or Hashtable.containskey(strkey) Then HashTableRemoveKey = False
End Function
'[|:---------VBA Hash Class---------------------:|]
Function ClearHashTable()
On Error Resume Next
Hashtable.Clear
If Err.Number <> 0 Then
Debug.Print "Function ClearHashTable", Err.Number, Err.Description: Err.Clear
ClearHashTable = False
Exit Function
ElseIf Hashtable Is Nothing Or Hashtable.Count = 0 Then
ClearHashTable = True
Exit Function
Exit Function
End If
End Function
Function Removeall()
Hashtable.Removeall
End Function
'[|:---------VBA Hash Class---------------------:|]
Private Sub Class_Terminate()
Hashtable.Clear
If Not Hashtable Is Nothing Then Set Hashtable = Nothing
End Sub

Hash Table 標準モジュール

Sub testclsHashtable()
Dim clsHash As clsHashTable

: Set clsHash = New clsHashTable
With clsHash
.AddHashTbl 0, "tel"
.AddHashTbl 1, "fax"
.AddHashTbl 2, "IM"
.AddHashTbl 4, "Rw"
Debug.Print .rtnHashTable_Items_count
End With
End Sub

Queue Class

Option Explicit
' Ver 20190223
' ClassName= clsQueue
' DeQueue <- Return Item Value and Delete Item
'  I   IIIIIII   I
'               Push -> Add Item As Last Item
' ^ Peek Return First value but not delete
' First in First Out
' [Stack Class](https://docs.microsoft.com/ja-jp/dotnet/api/system.collections.stack?view=netframework-4.7.2)
'Class Private 変数宣言
Private Queue
' /// 初期化
Private Sub Class_Initialize()
Set Queue = CreateObject("System.Collections.Queue")
End Sub
'[|:---------VBA Queue Class---------------------:|]
Function AddQueue(varValue)
 Queue.Enqueue varValue 'null値可能
End Function
'[|:---------VBA Queue Class---------------------:|]
Function isContainsValue(varValue)
isContainsValue = Queue.Contains(varValue)
End Function
'[|:---------VBA Queue Class---------------------:|]
Function rtnQueuePeekValue()
rtnQueuePeekValue = Queue.peek
End Function
'[|:---------VBA Queue Class---------------------:|]
Function rtnQueueDeQueueValue()
'値を取得して削除する。その値は一番最初に入れられたものになる
rtnQueueDeQueueValue = Queue.dequeue
End Function
'[|:---------VBA Queue Class---------------------:|]
Function rtnQueue_Items_Count()
rtnQueue_Items_Count = Queue.Count
End Function
'[|:---------VBA Queue Class---------------------:|]
Public Property Get QueueToArray()
QueueToArray = Queue.toarray
End Property
'[|:---------VBA Queue Class---------------------:|]
Function ClearQueue()
On Error Resume Next
 Queue.Clear
If Err.Number <> 0 Then
Debug.Print "Function ClearQueue ", Err.Number, Err.Description: Err.Clear
ClearQueue = False
Exit Function
ElseIf Queue Is Nothing Or Queue.Count = 0 Then
ClearQueue = True
Exit Function
End If
End Function
'[|:---------VBA Queue Class---------------------:|]
Function Removeall()
 Queue.Clear
End Function
'[|:---------VBA Queue Class---------------------:|]
Private Sub Class_Terminate()
 Queue.Clear
If Not Queue Is Nothing Then Set Queue = Nothing
End Sub

Queue 標準モジュール

Sub testclsQueue()
Dim Que As Queue: Set Que = New Queue
Dim objQueue As clsQueue: Set objQueue = New clsQueue
Dim arQueue(), i, ar
With objQueue
.AddQueue "ss" Queueと Stackは本当はPushというが、Classを使って意識しないで入力できるようにしている。
.AddQueue "sa"
.AddQueue "si"
.AddQueue "su"
.AddQueue "ss"
.AddQueue "ss"
ar = .QueueToArray
End With
Set objQueue = Nothing
End Sub

Stack Class

Option Explicit
'ClassName= clsStack
' pop <- Return Value and Delete Value
'  I   IIIIIIII
' Push -> Add Item As First Item
' ^ Peek Return First value but not delete
' First in First Out
Private Stack
Private Sub Class_Initialize()
Set Stack = CreateObject("System.Collections.Stack")
End Sub
'[|:---------VBA Stack Class---------------------:|]
Function AddStack(Value)
 If Stack.Contains(Value) = False Then
 On Error Resume Next
 Stack.Push Value 'null値可能
 On Error GoTo 0
 If Err.Number = 0 Then AddStack = True: Exit Function Else Debug.Print Err.Number, Err.Description: Err.Clear: AddStack = False: Exit Function
 Else
 AddStack = False
 End If
End Function
'[|:---------VBA Stack Class---------------------:|]
Function PushStack(Value)
 If Stack.Contains(Value) = False Then
 On Error Resume Next
 Stack.Push Value 'null値可能
 On Error GoTo 0
 If Err.Number = 0 Then PushStack = True: Exit Function Else Debug.Print "PushStack", Err.Number, Err.Description: Err.Clear: PushStack = False: Exit Function
 Else
 PushStack = False
 End If
End Function
'[|:---------VBA Stack Class---------------------:|]
Function isContainsValue(Value)
isContainsValue = Stack.Contains(Value)
End Function
Function rtnstackPeekValue()
rtnstackPeekValue = Stack.peek
End Function
'[|:---------VBA Stack Class---------------------:|]
Function rtnstackDestackValue()
rtnstackDestackValue = Stack.Pop
End Function
'[|:---------VBA Stack Class---------------------:|]
Function rtnStack_Items_Count()
rtnStack_Items_Count = Stack.Count
End Function
'[|:---------VBA Stack Class---------------------:|]
Public Property Get StackToArray()
StackToArray = Stack.toarray
End Property
'[|:---------VBA Stack Class---------------------:|]
Function ClearStack()
On Error Resume Next
 Stack.Clear
If Err.Number <> 0 Then
Debug.Print "Function ClearStack", Err.Number, Err.Description: Err.Clear
ClearStack = False
Exit Function
ElseIf Stack Is Nothing Or Stack.Count = 0 Then
ClearStack = True
Exit Function
End If
End Function
'[|:---------VBA Stack Class---------------------:|]
Function Removeall()
' 本当はClearだがRemoveAllも同機能を持たせる
On Error Resume Next
 Stack.Clear
If Err.Number <> 0 Then
Debug.Print "Function ClearStack", Err.Number, Err.Description: Err.Clear
Removeall = False
Exit Function
ElseIf Stack Is Nothing Or Stack.Count = 0 Then
Removeall = True
Exit Function
End If
End Function
' /// 終了処理
Private Sub Class_Terminate()
 Stack.Clear
If Not Stack Is Nothing Then Set Stack = Nothing
End Sub

Stack 標準モジュール

Sub StackToArray()
Dim objStack As clsStack: Set objStack = New clsStack
Dim arStack(), i, ar
With objStack
.AddStack "ss"
.AddStack "sa"
.AddStack "si"
.AddStack "su"
.AddStack "Se"
ar = .StackToArray
End With
Set objStack = Nothing
End Sub
'''
#VBS版
##Stack

```visualbasic
Option Explicit
'ClassName= clsStack
' pop <- Return Value and Delete Value
'  I   IIIIIIII
' Push -> Add Item As First Item
' ^ Peek Return First value but not delete
' First in First Out
Class clsStack
Private Stack
Private Sub Class_Initialize()
Set Stack = CreateObject("System.Collections.Stack")
End Sub
'[|:---------VBScript Stack Class ----------------:|]
Function AddStack(Value)
 If Stack.Contains(Value) = False Then
 On Error Resume Next
 Stack.Push Value 'null値可能
 On Error GoTo 0
 If Err.Number = 0 Then AddStack = True: Exit Function Else Wscript.Echo Err.Number, Err.Description: Err.Clear: AddStack = False: Exit Function
 Else
 AddStack = False
 End If
End Function
'[|:---------VBScript Stack Class ----------------:|]
Function PushStack(Value)
 If Stack.Contains(Value) = False Then
 On Error Resume Next
 Stack.Push Value 'null値可能
 On Error GoTo 0
 If Err.Number = 0 Then PushStack = True: Exit Function Else Wscript.Echo "PushStack", Err.Number, Err.Description: Err.Clear: PushStack = False: Exit Function
 Else
 PushStack = False
 End If
End Function
'[|:---------VBScript Stack Class ----------------:|]
Function isContainsValue(Value)
isContainsValue = Stack.Contains(Value)
End Function
Function rtnstackPeekValue()
rtnstackPeekValue = Stack.peek
End Function
'[|:---------VBScript Stack Class ----------------:|]
Function rtnstackDestackValue()
rtnstackDestackValue = Stack.Pop
End Function
'[|:---------VBScript Stack Class ----------------:|]
Function rtnStack_Items_Count()
rtnStack_Items_Count = Stack.Count
End Function
'[|:---------VBA Stack Class---------------------:|]
Public Property Get StackToArray()
StackToArray = Stack.toarray
End Property
'[|:---------VBScript Stack Class ----------------:|]
Function ClearStack()
On Error Resume Next
 Stack.Clear
If Err.Number <> 0 Then
Wscript.Echo "Function ClearStack", Err.Number, Err.Description: Err.Clear
ClearStack = False
Exit Function
ElseIf Stack Is Nothing Or Stack.Count = 0 Then
ClearStack = True
Exit Function
End If
End Function
'[|:---------VBScript Stack Class ----------------:|]
Function Removeall()
' 本当はClearだがRemoveAllも同機能を持たせる
On Error Resume Next
 Stack.Clear
If Err.Number <> 0 Then
Wscript.Echo "Function ClearStack", Err.Number, Err.Description: Err.Clear
Removeall = False
Exit Function
ElseIf Stack Is Nothing Or Stack.Count = 0 Then
Removeall = True
Exit Function
End If
End Function
'[|:---------VBScript Stack Class ----------------:|]
' /// 終了処理
Private Sub Class_Terminate()
 Stack.Clear
If Not Stack Is Nothing Then Set Stack = Nothing
End Sub
End Class
''''/// VBScript Main Block //// ''''
Dim objStack : Set objStack = New clsStack
Dim arStack(), i, ar
With objStack
.AddStack "ss"
.AddStack "sa"
.AddStack "si"
.AddStack "su"
.AddStack "Se"
ar = .StackToArray : Wscript.Echo "ar" , Ubound(ar)
End With
Set objStack = Nothing

参考文献

[C#] HashTableに同じキーで追加した際に値を上書きする方法 2008-02-28
未実験
arrays VBA - プロパティから配列を返すGet
ArrayListのジェネリック

インスタンス化するときに、データ型を指定するので、取り出すときキャストする必要がありません。どんなデータ型でも使用できます。
注意としては、もともとオブジェクト型なので、Stringでインスタンス化しても他の型のデータも受け入れてしまうところです。
ArrayList　Hashtable　SortedList　Queue　Stack
VBSで使える連想配列 Dictionary、Hashtable、SortedList
VBSでキュー(Queue)、スタック(Stack)を使う
Stack Class
シンプルな後入れ先出し (LIFO) の非ジェネリック オブジェクト コレクションを表します。 一部のブログではジェネリックとしているが、公式は非ジェネリックとしている
Stackクラスの新しい開発に使用することをお勧めしません、System.Collections.Generic.Stackクラスを使用してください。 詳細については、次を参照してください。非ジェネリック コレクションを使用してはならないGitHub でします。 ただし、これはVBAでは呼び出せないので、これを依然として使うことになる。
Queue Class
列挙可能から完全なるモノまで – IEnumerableの探索 – C# Advent Calendar 2014