Hallo,
ich habe hier einmal ein paar Funktionen zu Arrays zu einer Klasse zusammengefasst:
%Include "Lserr.lss"
Public Class Array
Public Array() As Variant
Private valueLookingFor As Variant '* used by the GetNextOccurence
function
'********
'* NEW
'********
Sub New
Redim Array(0)
End Sub
'*****************************
'* APPEND NEW VALUE
'*****************************
Sub AppendNewValue( newValue As Variant )
'* Appends new value to end of array
If Ubound( Array ) = 0 And array( Ubound( array ) ) = "" Then
'* Array was probably just initialized, use the first
opening
Array( Ubound( Array ) ) = newValue
Else
Redim Preserve Array ( Ubound( Array ) + 1 )
Array( Ubound( Array ) ) = newValue
End If
End Sub
'***************
'* INITIALIZE
'***************
Sub Initialize( newValues As Variant )
'* takes an existing array and populates Class array
Redim Array(0)
Forall value In newValues
Me.AppendNewValue( value )
End Forall
End Sub
'**********************
'* GET UBOUNDS
'**********************
Property Get UBounds As Integer
On Error Goto ErrHandler
UBounds = Ubound( Array )
Exit Property
errHandler:
If Err = ErrUninitDynArray Then
'* array hasn't been initialized yet, return -1
UBounds = -1
End If
Exit Property
End Property
'*********************
'* GET LBOUNDS
'*********************
Property Get LBounds As Integer
On Error Goto ErrHandler
LBounds = Lbound( Array )
Exit Property
errHandler:
If Err = ErrUninitDynArray Then
'* array hasn't been initialized yet, return -1
LBounds = -1
End If
Exit Property
End Property
'*********************
'* SET UBOUNDS
'*********************
Property Set UBounds As Integer
On Error Goto ErrHandler
tempLBounds = Me.LBounds
If tempLBounds = -1 Then
'* Array hasn't been initialized yet
'* we don't know LBounds, so make it the same as UBounds
Redim Array( UBounds To UBounds )
Elseif tempLBounds > UBounds Then
'* do nothing, leave the array
Else
'* Array has been initialized, redim it
Redim Array( tempLBounds To UBounds )
End If
Exit Property
errHandler:
Exit Property
End Property
'*********************
'* SET LBOUNDS
'*********************
Property Set LBounds As Integer
On Error Goto ErrHandler
tempUBounds = Me.UBounds
Select Case tempUBounds
Case Is = -1
'* Array hasn't been initialized yet
'* we don't know UBounds, so make it the same as UBounds
Redim Array( LBounds To LBounds )
Case Is = 0
'* assume user doesn't care about upper bounds if it's
only 0
Redim Array( LBounds To LBounds )
Case Is < LBounds
'* do nothing, can't have lower bound bigger than upper
bound
Case Else
Redim Array( LBounds To tempUBounds )
End Select
Exit Property
errHandler:
Exit Property
End Property
'************************
'* RETURN ARRAY
'************************
Sub ReturnArray( newArray() As Variant )
'* returns an array representing the Class array
Redim newArray( Me.LBounds To Me.UBounds )
For x = Me.LBounds To Me.UBounds
newArray( x ) = Array( x )
Next
End Sub
'*****************
'* GET COUNT
'*****************
Property Get Count As Integer
'* Returns number of values in an array
For x = Me.LBounds To Me.UBounds
counter = counter + 1
Next
Count = counter
End Property
'**********************************
'* FIND FIRST OCCURENCE
'**********************************
Function FindFirstOccurence( valueToFind As Variant ) As Integer
'* finds first occurence of a value
valueLookingFor = valueToFind
For x = Me.LBounds To Me.UBounds
counter = counter + 1
If Array( x ) = valueLookingFor Then
FindFirstOccurence = counter
Exit Function
End If
Next
FindFirstOccurence = -1 '* didn't find an occurence
End Function
'**********************************
'* FIND NEXT OCCURENCE
'**********************************
Function FindNextOccurence( PrevOccurence As Integer ) As Integer
'* finds next occurence of value, returns -1 if not found
For x = Me.LBounds To Me.UBounds
counter = counter + 1
If counter > PrevOccurence Then
If Array( x ) = valueLookingFor Then
FindNextOccurence = counter
Exit Function
End If
Else
'* don't start searching yet
End If
Next
FindNextOccurence = -1 '* didn't find an occurence
End Function
'***********************
'* GET NTH VALUE
'***********************
Function GetNthValue( n As Integer ) As Variant
'* This will grab a value for the Nth position
'* make sure n is within bounds first
If n > Me.Count Or n <= 0 Then
GetNthValue = False
Exit Function
End If
For x = Lbound( Array ) To Ubound( Array )
counter = counter + 1
If counter = n Then
GetNthValue = Array( x )
Exit Function
End If
Next
End Function
'***********************
'* SET NTH VALUE
'***********************
Function SetNthValue( n As Integer, newValue As Variant ) As
Variant
'* Find the Nth position, and set it's value
'* make sure n isn't lower than bounds first
If n < 0 Then
SetNthValue = False
Exit Function
End If
If n > Me.Count Then
Redim Preserve Array( Me.LBounds To n )
Array( n ) = newValue
SetNthValue = True
Exit Function
End If
For x = Lbound( Array ) To Ubound( Array )
counter = counter + 1
If counter = n Then
Array( x ) = newValue
SetNthValue = True
Exit Function
End If
Next
SetNthValue = False
End Function
'******************************
'* REMOVE NTH VALUE
'******************************
Function RemoveNthValue( n As Integer ) As Variant
'* not only remove the value, but shrink the array size too
'* make sure n is within bounds first
If n > Me.Count Or n <= 0 Then
RemoveNthValue = False
Exit Function
End If
Dim newArray() As Variant, found As Variant
Redim newArray( Me.LBounds To ( Me.UBounds - 1 ) )
found = False
For x = Lbound( Array ) To Ubound( Array )
counter = counter + 1
If counter <> n Then
If found = False Then
newArray( x ) = Array( x )
Else
newArray( x - 1 ) = Array ( x )
End If
Else
found = True
End If
Next
Redim Array( Me.LBounds To ( Me.UBounds - 1 ) )
For x = Lbound( Array ) To Ubound( Array )
Array( x ) = newArray( x )
Next
RemoveNthValue = True
End Function
'******************************************
'* REMOVE DUPLICATE ENTRIES
'******************************************
Sub RemoveDuplicateEntries
'* Just what the subprocedure's title indicates
Dim tempArray List As Variant
'* Use list to remove duplicates as list tags have to be
unique
Forall value In Array
tempArray(value) = value
End Forall
'* Swap arrays
Forall temp In tempArray
counter = counter + 1 '* Figure out how many entries
there are
End Forall
If Me.LBounds = 0 Then '* if it's zero, subtract one from
counter, otherwise, we'll have an extra entry
Redim Preserve Array( Me.LBounds To ( counter - 1 ) )
Else
Redim Preserve Array( Me.LBounds To counter )
End If
x = Me.LBounds
Forall temp In tempArray
Array( x ) = temp
x = x + 1
End Forall
End Sub
'************************
'* REMOVE SPACES
'************************
Sub RemoveSpaces
'* This removes any values from the array that are equal to
""
continue = True
If Me.LBounds = Me.UBounds Then '* don't want to touch it if
there is only one value
continue = False
End If
Do While continue = True
counter = 0 '* reset counter
For x = Me.LBounds To Me.UBounds
counter = counter + 1
If Array( x ) = "" Then
'* get rid of this one
Me.RemoveNthValue( counter )
Exit For
End If
Next
'* check if there is another occurence of "", if so,
keep going
Occurence = Me.FindFirstOccurence( "" )
If Occurence <> -1 Then
continue = True
Else
continue = False
End If
Loop
End Sub
'*********
'* SORT
'*********
Sub Sort( SortType As Variant )
'* SortType is True for Ascending order, False for Descending
order
Dim lowerBounds, upperBounds, cur, cur2 As Integer
Dim temp As Variant
upperBounds = Me.UBounds
lowerBounds = Me.LBounds
If upperBounds = lowerBounds Then Exit Sub
For cur = lowerBounds To upperBounds
cur2 = cur
Do While cur2 > lowerBounds 'bubble up
If SortType Then '* sort ascending
If ( Array( cur2 ) > Array(cur2 - 1) ) Then
Exit Do
Else
temp = Array( cur2 )
Array( cur2 ) = Array( cur2-1 )
Array(cur2-1) = temp
End If
Else '* sort descending
If ( Array( cur2 ) < Array(cur2 - 1) ) Then
Exit Do
Else
temp = Array( cur2 )
Array( cur2 ) = Array( cur2-1 )
Array(cur2-1) = temp
End If
End If
cur2 = cur2-1
Loop
Next
End Sub
'****************
'* ISMEMBER
'****************
Function IsMember( value As Variant ) As Variant
'* returns true if value passed is in list, false if not
found
For x = Me.LBounds To Me.UBounds
If Array( x ) = value Then
IsMember = True
Exit Function
End If
Next
IsMember = False
End Function
'*****************
'* ISNOTHING
'*****************
Function IsNothing As Variant
'* determines if array is completely empty
For x = Me.LBounds To Me.UBounds
If Array( x ) <> "" Then
IsNothing = False
Exit Function
End If
Next
IsNothing = True
End Function
End Class
