Skip to content

Commit de83654

Browse files
OlimilO1402OlimilO1402
committed
added interfaces Stack & Queue to the class List
only available if you set conditional ListAsStack=1 and ListAsQueue=1 So there is no need to change already existing code
1 parent 86ac17d commit de83654

7 files changed

Lines changed: 341 additions & 36 deletions

File tree

‎Classes/List.cls‎

Lines changed: 121 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -12,6 +12,15 @@ Attribute VB_Creatable = True
1212
Attribute VB_PredeclaredId = False
1313
Attribute VB_Exposed = False
1414
Option Explicit
15+
#If ListAsStack Then
16+
Implements Stack
17+
#End If
18+
#If ListAsQueue Then
19+
Implements Queue
20+
#End If
21+
22+
23+
1524
'https://docs.microsoft.com/en-us/openspecs/windows_protocols/ms-oaut/3fe7db9f-5803-4dc4-9d14-5425d3f5461f
1625
' typedef enum tagVARENUM
1726
' {
@@ -400,10 +409,10 @@ End Property
400409
Public Sub AddRange(aArr) 'As List
401410
' Fügt die Elemente der angegebenen Auflistung der List hinzu
402411
If VBA.Information.IsEmpty(aArr) Then Exit Sub
403-
Dim i As Long, v
412+
Dim i As Long, V
404413
If TypeOf aArr Is List Then
405-
For Each v In aArr.GetEnumerator
406-
Me.Add v
414+
For Each V In aArr.GetEnumerator
415+
Me.Add V
407416
Next
408417
Else
409418
If m_DataType = vbWChar Then
@@ -424,13 +433,13 @@ Public Sub AddRange(aArr) 'As List
424433
End If
425434
ElseIf m_DataType = vbUserDefinedType Then
426435
For i = 0 To UBound(aArr)
427-
v = aArr(i)
428-
Me.Add v
436+
V = aArr(i)
437+
Me.Add V
429438
Next
430439
Else
431440
'für Collection oder Array
432-
For Each v In aArr
433-
Me.Add v
441+
For Each V In aArr
442+
Me.Add V
434443
Next
435444
End If
436445
End If
@@ -465,10 +474,10 @@ Public Function Clone() As List
465474
Set Clone = New List: Clone.NewC Me
466475
End Function
467476

468-
Public Function ContainsEqualObj(obj As Object) As Boolean
477+
Public Function ContainsEqualObj(Obj As Object) As Boolean
469478
Dim i As Long
470479
For i = 0 To m_Count - 1
471-
If m_Arr(i).Equals(obj) Then
480+
If m_Arr(i).Equals(Obj) Then
472481
ContainsEqualObj = True: Exit Function
473482
End If
474483
Next
@@ -495,12 +504,12 @@ Public Function ContainsKey(Key As String) As Boolean
495504
On Error GoTo 0
496505
End Function
497506

498-
Public Function ContainsObj(obj, Optional ByVal ObjUseKey As Boolean = False) As Boolean
507+
Public Function ContainsObj(Obj, Optional ByVal ObjUseKey As Boolean = False) As Boolean
499508
'Bestimmt, ob sich ein Element in der Liste befindet.
500509
On Error Resume Next
501510
Dim Key As String
502511
If m_IsHashed Then
503-
If m_DataType = vbObject Then Key = obj.Key Else Key = obj
512+
If m_DataType = vbObject Then Key = Obj.Key Else Key = Obj
504513
If VBA.IsEmpty(m_HashI(Key)) Then: 'DoNothing
505514
ContainsObj = (Err.Number = 0)
506515
Else
@@ -513,7 +522,7 @@ Public Function ContainsObj(obj, Optional ByVal ObjUseKey As Boolean = False) As
513522
If m_Arr(i).Key = Key Then ContainsObj = True: Exit Function
514523
Next
515524
Else
516-
Dim pObj As Long: pObj = ObjPtr(obj)
525+
Dim pObj As Long: pObj = ObjPtr(Obj)
517526
For i = 0 To m_Count - 1
518527
If ObjPtr(m_Arr(i)) = pObj Then ContainsObj = True: Exit Function
519528
Next
@@ -524,7 +533,7 @@ Public Function ContainsObj(obj, Optional ByVal ObjUseKey As Boolean = False) As
524533
'Key = Obj
525534
For i = 0 To m_Count - 1
526535
'If CStr(m_Arr(i)) = Key Then Contains = True: Exit Function
527-
If m_Arr(i) = obj Then ContainsObj = True: Exit Function
536+
If m_Arr(i) = Obj Then ContainsObj = True: Exit Function
528537
Next
529538
End Select
530539
End If
@@ -536,6 +545,10 @@ Public Property Get Count() As Long
536545
Count = m_Count
537546
End Property
538547

548+
Public Sub CopyTo(Arr())
549+
Arr = m_Arr
550+
End Sub
551+
539552
Public Function GetEnumerator() 'As Variant ' 'As IUnknown
540553
Attribute GetEnumerator.VB_UserMemId = -4
541554
'Prozedur-ID = -4
@@ -622,12 +635,12 @@ Public Property Get ItemByKey(aKey As String)
622635
End Property
623636

624637
Public Property Get IndexOf(Value) As Long
625-
Dim i As Long, obj As Object
638+
Dim i As Long, Obj As Object
626639
IndexOf = -1 'first we assume its not in list
627640
If m_IsHashed Then
628641
Dim Key As String
629642
Select Case m_DataType
630-
Case vbObject: Set obj = Value: Key = obj.Key
643+
Case vbObject: Set Obj = Value: Key = Obj.Key
631644
Case vbString: Key = Value
632645
Case Else: Key = Value
633646
End Select
@@ -923,8 +936,8 @@ Public Sub Remove(ByVal Index As Long)
923936
If m_IsHashed Then ReInitIndices
924937
End Sub
925938

926-
Public Sub RemoveObj(obj As Object)
927-
Dim i As Long: i = IndexOf(obj)
939+
Public Sub RemoveObj(Obj As Object)
940+
Dim i As Long: i = IndexOf(Obj)
928941
'if Obj is not contained IndexOf returns -1
929942
If i < 0 Then Exit Sub
930943
Remove i
@@ -1168,10 +1181,10 @@ Private Function divideObj(ByVal i1 As Long, ByVal i2 As Long) As Long
11681181
divideObj = i
11691182
End Function
11701183
Private Function CompareObj(ByVal i1 As Long, ByVal i2 As Long) As Long
1171-
Dim obj1 As Object: Set obj1 = m_Arr(i1)
1172-
Dim obj2 As Object: Set obj2 = m_Arr(i2)
1184+
Dim Obj1 As Object: Set Obj1 = m_Arr(i1)
1185+
Dim Obj2 As Object: Set Obj2 = m_Arr(i2)
11731186
'CompareObj = m_Arr(i1).Compare(m_Arr(i2))
1174-
CompareObj = obj1.Compare(obj2)
1187+
CompareObj = Obj1.Compare(Obj2)
11751188
End Function
11761189
Private Sub SwapObj(ByVal i1 As Long, ByVal i2 As Long)
11771190
Dim tmp As Object: Set tmp = m_Arr(i1)
@@ -1840,3 +1853,91 @@ Private Function ErrHandler(ByVal FuncName As String, _
18401853
End If
18411854

18421855
End Function
1856+
1857+
' ############################## ' Implements Stack ' ############################## '
1858+
Private Sub Stack_Clear()
1859+
Me.Clear
1860+
End Sub
1861+
1862+
Private Function Stack_Clone() As Stack
1863+
Set Stack_Clone = Me.Clone
1864+
End Function
1865+
1866+
Private Function Stack_Contains(Obj As Object) As Boolean
1867+
Stack_Contains = Me.ContainsObj(Obj)
1868+
End Function
1869+
1870+
Private Sub Stack_CopyTo(Arr() As Variant)
1871+
Me.CopyTo Arr
1872+
End Sub
1873+
1874+
Private Property Get Stack_Count() As Long
1875+
Stack_Count = Me.Count
1876+
End Property
1877+
1878+
Private Function Stack_Peek() As Variant
1879+
'gibt das oberste Object vom Stack zurück ohne es zu entfernen
1880+
If m_DataType = vbObject Then
1881+
Set Stack_Peek = Me.SPeek
1882+
Else
1883+
Stack_Peek = Me.SPeek
1884+
End If
1885+
End Function
1886+
1887+
Private Function Stack_Pop() As Variant
1888+
'Entfernt das Object oben vom Stack und gibt es zurück
1889+
If m_DataType = vbObject Then
1890+
Set Stack_Pop = Me.SPop
1891+
Else
1892+
Stack_Peek = Me.SPop
1893+
End If
1894+
End Function
1895+
1896+
Private Sub Stack_Push(Obj As Variant)
1897+
'Fügt ein Object am Anfang des Stack ein
1898+
Me.SPush Obj
1899+
End Sub
1900+
1901+
' ############################## ' Implements Queue ' ############################## '
1902+
Private Sub Queue_Clear()
1903+
Me.Clear
1904+
End Sub
1905+
1906+
Private Function Queue_Clone() As Queue
1907+
Set Queue_Clone = Me.Clone
1908+
End Function
1909+
1910+
Private Function Queue_Contains(Obj) As Boolean
1911+
Queue_Contains = Me.ContainsObj(Obj)
1912+
End Function
1913+
1914+
Private Sub Queue_CopyTo(Arr() As Variant)
1915+
Me.CopyTo Arr
1916+
End Sub
1917+
1918+
Private Property Get Queue_Count() As Long
1919+
Queue_Count = Me.Count
1920+
End Property
1921+
1922+
Private Function Queue_Dequeue() As Variant
1923+
'Entfernt das Objekt am Anfang der Queue und gibt es zurück
1924+
If m_DataType = vbObject Then
1925+
Set Queue_Dequeue = Me.QDequeue
1926+
Else
1927+
Queue_Dequeue = Me.QDequeue
1928+
End If
1929+
End Function
1930+
1931+
Private Function Queue_Enqueue(Obj) As Variant
1932+
Me.QEnqueue Obj
1933+
End Function
1934+
1935+
Private Function Queue_Peek() As Variant
1936+
'gibt das Object am Anfang der Queue zurück ohne es zu entfernen
1937+
If m_DataType = vbObject Then
1938+
Set Queue_Peek = Me.QPeek
1939+
Else
1940+
Queue_Peek = Me.QPeek
1941+
End If
1942+
End Function
1943+

‎Classes/Queue.cls‎

Lines changed: 23 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,23 @@
1+
VERSION 1.0 CLASS
2+
BEGIN
3+
MultiUse = -1 'True
4+
Persistable = 0 'NotPersistable
5+
DataBindingBehavior = 0 'vbNone
6+
DataSourceBehavior = 0 'vbNone
7+
MTSTransactionMode = 0 'NotAnMTSObject
8+
END
9+
Attribute VB_Name = "Queue"
10+
Attribute VB_GlobalNameSpace = False
11+
Attribute VB_Creatable = True
12+
Attribute VB_PredeclaredId = False
13+
Attribute VB_Exposed = False
14+
Option Explicit
15+
Public Sub Clear(): End Sub
16+
Public Function Clone() As Queue: End Function
17+
Public Function Contains(Obj) As Boolean: End Function
18+
Public Sub CopyTo(Arr()): End Sub
19+
Public Property Get Count() As Long: End Property
20+
Public Function Dequeue(): End Function
21+
Public Function Enqueue(Obj): End Function
22+
Public Function Peek(): End Function
23+

‎Classes/Stack.cls‎

Lines changed: 22 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,22 @@
1+
VERSION 1.0 CLASS
2+
BEGIN
3+
MultiUse = -1 'True
4+
Persistable = 0 'NotPersistable
5+
DataBindingBehavior = 0 'vbNone
6+
DataSourceBehavior = 0 'vbNone
7+
MTSTransactionMode = 0 'NotAnMTSObject
8+
END
9+
Attribute VB_Name = "Stack"
10+
Attribute VB_GlobalNameSpace = False
11+
Attribute VB_Creatable = True
12+
Attribute VB_PredeclaredId = False
13+
Attribute VB_Exposed = False
14+
Option Explicit
15+
Public Sub Clear(): End Sub
16+
Public Function Clone() As Stack: End Function
17+
Public Function Contains(Obj As Object) As Boolean: End Function
18+
Public Sub CopyTo(Arr()): End Sub
19+
Public Property Get Count() As Long: End Property
20+
Public Function Peek(): End Function
21+
Public Function Pop(): End Function
22+
Public Sub Push(Obj): End Sub

0 commit comments

Comments
 (0)