Similar to the functionality of the Vector class in Java
application
DIM V AS New Vector () Call v.addelement ("Domino") Call v.addelement ("notes") Call v.addelement ("R5") Print "Elements Are:" & v.toString ()
Source code:
Composed of three classes: Vector VectorEnumeration Enumeration
Public Class Vector array As Variant elementLength As Integer capacityIncrement As Integer Public Sub new () elementLength = 0 ensureCapacity (10) End Sub Public Sub copyInto (outArray As Variant) Dim i As Integer For i = Me.size () - 1 To 0 Step -1 OutArray (i) = array (i) Next I end Sub public sub trimtosize () if me.size ()
0 Then Exit Function Me.capacity = Ubound (array) - Lbound (array) 1 End Function Public Function isEmpty () As Variant Me.isEmpty = (elementLength = 0) End Function Public Function elements () As Enumeration Set elements = New VectorEnumeration (Me) End Function Public Function contains (element As Variant) As Variant contains = False If Not indexOf (element) = -1 Then contains = True End Function Public Function indexOf (element As Variant) As Integer On Error Goto handleError indexOf = -1 DIM I as integer for i = 0 to ElementLength - 1 if Equals (Element, Array (i)) THENEDEXOF = I Exit function end if NexthandleExit: Exit FunctionHandleError: Print "Error" & Err & "," & Error & "in line" & erl & ", function" & lsi_info (2) Error Err, Error Resume Handlexit End Function Public Function LastIndexOf (Element As Variant) AS Integer LastIndexOf = -1 Dim i as integer for i = me.size () -1 to 0 Step -1 if Equals (Element, Array (i)) Then LastIndexOf = I EXIT FU nction End If Next End Function Private Function equals (element1 As Variant, element2 As Variant) As Integer Me.equals = False If Isobject (element1) And Not Isobject (element2) Then Exit Function If Isobject (element1) Then If element1 Is element2 Then equals = True Else If element1 = element2 Then equals = True End If End Function Public Function elementAt (index As Integer) As Variant If (index <0) Or (index => Me.size ()) Then Error 2000, "Array index Out of bounds "if isobject (array (index)) THEN SET ELSE ELEMENTAT =
array (index) End If End Function Public Function firstElement () As Variant If Isobject (elementAt (0)) Then Set firstElement = elementAt (0) Else firstElement = elementAt (0) End If End Function Public Function lastElement () As Variant If ISOBJECT (Elementat (Me.Size () - 1)) THEN SETLASTELEMENT = ELSE LASTELEMENT = ELSE LASTELEMENT = Elementat (me.size () - 1) end if End function public function setElementat (Element as Variant, INDEX AS INTEGER IF INDEX> = Me.Size () THEN Error 2000, "Array Index [" & "] Out of Bounds [" & size & "]" ing isobject (element) THEN SET ARRAY (Index = ELSE ARRAY (INDEX) = ELEMENT END IF END FUNCTION PUBLIC FUNCTION RemoveElementat (INDEX AS INTEGER) IF INDEX> = Me.Size () Then Error 2000, "Array Index [" & INDEX & "] Out of Bounds [" & size & "]" DIM MEMBERS AS VARIANT DIM I AS INTEGER DIM J AS INTEGER Redim Members (me.size ()) j = 0 for i = 0 to me.size-1 if (i <> index) and (Not J> me.size ()) THEN MEMBERS (j) = array (i) j = j 1 End If Next i elementLength = elementLength - 1 array = members End Function Public Function insertElementAt (element As Variant, index As Integer) Dim newSize As Integer newSize = Me.size () 1 If index> = newSize Then Error 2000, "Array Index [" & "] Out of Bounds [" & Newsize & "]" If Newsize> Capacity Then EnSureCapacity (newsize) 'hmmm ... import how? Dim target () As Variant Redim Target (0 to Capacity) AS VARIANT DIM I AS INTEGER FOR I =
0 TO news TARGET (I) = ELSE TARGET (I) = ELSE TARGET (I) = ELEMENT ELSE TARGET (I) = ELEMENT ELSE TARGET (I) = Element Elseif i> Index THEN TARGET (i) = array (i-1) else target (i) = array (i) End If Next i array = target elementLength = elementLength 1 End Function Public Sub addElement (element As Variant) Dim newSize As Integer newSize = Me.size () 1 If newSize> capacity Then ensureCapacity ( newSize) If Isobject (element) Then Set array (Me.size ()) = element Else array (Me.size ()) = element End If elementLength = elementLength 1 End Sub Public Sub addElements (elements As Variant) 'Adds all elements in the specified array or list If Not Isarray (elements) And Not Islist (elements) Then Call Me.addElement (elements) Else Forall x in elements Call Me.addElement (x) End Forall End If End Sub Public Function removeElement (element As Variant RemoveElelelement = False Dim I as INTEGER I = Indexof (Element) if i> = 0 THEN Remov Elementat (i) RemoveElelement = true exit function end if End function public Sub RemoveAllelements () DIM I as integer for i = 0 to me.size () - 1 IF isobject (array (i)) THEN SET Array (i) = Nothing Else Array (i) = "" END IF NEXT I End SUB PUBLIC FUNCTION IMPLODE (BYVAL SEPARATOR AS STRING) AS String 'Creates A String of All Elements in Array, And The Argument As Separator. Me.implande = "IF ME. SIZE <= 0 THEN EXIT FUNCTION DIM I AS INTEGER DIM S AS STRING FOR i = 0 to me.size-2 if TypeName (Me.Array (i)) = "String" THEN S = S & Me.Array (i) &
Separator Elseif IsObject (Array (i)) THEN S = S & Me.Array (i) .tostring () & Separator Else S = S & CSTR (ME.Array (i)) & Separetor End if Next S = S & Me .array (size-1) 'Do not append the separator to the last element Me.implode = s End Function Sub unique ()' Removes all duplicates in the internal array. Somewhat slow on really big arrays ... If Me.isEmpty () THEN EXIT SUB DIM V AS New Vector () DIM I as Integer for i = 0 to me.size-1 if NOT V.CONTAINS (Me.Array (i)) THEN CALL V.ADDELEMENT (ME.Array (i NEXT I DIM A As Variant Redim A (v.size () - 1) Call v.copyinto (a) Me.Array = a me.elementLength = Ubound (array) - LBound (array) 1 set v = Nothing End Sub Public Function toString () As String toString = Me.implode ( ",") End FunctionEnd ClassPublic Class VectorEnumeration As Enumeration v As Vector index As Integer Public Sub new (v As Vector) Set Me.v = v index = 0 End Sub public function hasmorelements () as variant hasmorelements = (index Public Class Enumeration Public Function hasMoreElements () As Variant Error 2000, Typename (Me) & "." & Lsi_Info (2) & "not implemented" End Function Public Function nextElement () As Variant Error 2000, Typename (Me) & ". "& Lsi_info (2) &" Not Implement "End Functionend Class
