Page 1 sur 1
Manipulation de liste
Publié:
16 Fév 2007 à 12:19par billbock
- Code : Tout sélectionner
Class Array2
' MEMBERS =================================
Private pArray As Variant
Private pDataType As String
' PUBLIC PROCEDURES =======================
Public Property Get isEmpty As Integer
' Check is array is initialized or not
' to use : Me.isEmpty
~isEmpty = isArrayInitialized()
End Property
Public Property Get values As Variant
values = pArray
End Property
' PRIVATE PROCEDURES =====================
Private Function isArrayInitialized () As Integer
Dim size As Integer
size = -1
On Error Resume Next
size = Ubound(pArray)
If size = -1 Then
IsArrayInitialized = False
Else
IsArrayInitialized = True
End If
End Function
' CONSTRUCTOR ============================
Public Sub new(value As Variant)
Dim singleValue As Integer
Select Case Datatype(value)
Case V_INTEGER : Redim pArray(0) As Integer
singleValue = True
Case V_LONG : Redim pArray(0) As Long
singleValue = True
Case V_SINGLE : Redim pArray(0) As Single
singleValue = True
Case V_DOUBLE : Redim pArray(0) As Double
singleValue = True
Case V_CURRENCY : Redim pArray(0) As Currency
singleValue = True
Case V_DATE : Redim pArray(0) As Variant
singleValue = True
Case V_STRING : Redim pArray(0) As String
singleValue = True
Case V_DISPATCH : Redim pArray(0) As Variant
singleValue = True
Case V_ERROR : Redim pArray(0) As Variant
singleValue = True
Case V_BOOLEAN : Redim pArray(0) As Variant
singleValue = True
Case V_VARIANT : singleValue = False
Case V_IUNKNOWN : Redim pArray(0) As Variant
singleValue = True
Case V_LSOBJ : Redim pArray(0) As Variant
singleValue = True
Case V_PRODOBJ : Redim pArray(0) As Variant
singleValue = True
Case Else
singleValue = False
%REM
2048 List
8192 Fixed array
8704 Dynamic array
%END REM
End Select
If singleValue Then
pArray(0) = value
Else
Redim pArray(Ubound(value) - Lbound(value))
End If
End Sub
End Class
'_____________________________________________________________________
Public Class Array
'**************************************************
'* Introducing a better way to handle arrays
'**************************************************
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)
If Isarray( newValues ) Then
Forall value In newValues
Me.AppendNewValue( value )
End Forall
Else
Me.AppendNewValue( newValues )
End If
End Sub
'**********************
'* GET UBOUNDS
'**********************
Property Get UBounds As Integer
On Error Goto ErrHandler
UBounds = Ubound( Array )
Exit Property
errHandler:
If Err = 200 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 = 200 Then
'* array hasn't been initialized yet, return -1
LBounds = -1
End If
Exit Property
End Property
'*********************
'* SET UBOUNDS
'*********************
Property Set UBounds As Integer
Dim tempLBounds 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
Dim tempUBounds 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
Dim x As Integer
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
Dim x As Integer, counter As Integer
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
Dim x As Integer, counter As Integer
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
Dim x As Integer, counter As Integer
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
Dim x As Integer, counter As Integer
If n > Me.Count Or n < 0 Then
GetNthValue = ""
Exit Function
End If
counter = Me.LBounds
For x = Me.LBounds To Me.UBounds
If counter = n Then
GetNthValue = Array( x )
Exit Function
End If
counter = counter + 1
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
Dim x As Integer, counter As Integer
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
Dim x As Integer, counter As Integer
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 s As New NotesSession
Dim doc As NotesDocument
Dim tmpArray As Variant, arrayContents() As Variant
Set doc = New NotesDocument(s.CurrentDatabase)
Call Me.ReturnArray( arrayContents() )
doc.Array = ""
doc.Array = arrayContents
tmpArray = Evaluate("@Trim(@Unique(Array))", doc)
Call Me.Initialize( tmpArray )
%REM
'* Old method
Dim x As Integer, counter As Integer
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
%ENDREM
End Sub
'************************
'* REMOVE SPACES
'************************
Sub RemoveSpaces
'* This removes any values from the array that are equal to ""
Dim continue As Variant, counter As Integer, x As Integer, Occurence As Integer
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
Dim x As Integer
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
Dim x As Integer
For x = Me.LBounds To Me.UBounds
If Array( x ) <> "" Then
IsNothing = False
Exit Function
End If
Next
IsNothing = True
End Function
End Class