[RESOLVED] HELP delete a specific element of an Array

[*PsyKE1*]

I need to know which is the fastest way to delete a specific element of an Array ...
This is my code:

Private Sub Delete_Array_Item(ByRef lArray() As Long, ByVal lIndex As Long)
    Dim lCount      As Long
    Dim x           As Long
 
    lCount = UBound(lArray)
    If lIndex <= lCount And lIndex >= LBound(lArray) Then
        For x = lIndex To lCount - 1
            lArray(x) = lArray(x + 1)
        Next
        ReDim Preserve lArray(lCount - 1)
    End If
End Sub

Thanks

[baja_yu]

Depending on the size of the array, it might be faster to use a linked list.

[Edgemeal]

Would this help?

Option Explicit
Private Declare Sub RtlMoveMemory Lib "Kernel32" (ByVal Destination As Any, ByVal Source As Any, ByVal length As Long)
Dim MyArray() As Long ' our Long array

Private Sub Form_Load()
    ReDim MyArray(9) As Long ' size our array
End Sub

Private Sub Command1_Click()
    ' // Testing - ArrayRemoveLong //
    Dim L As Long
    On Error GoTo ArrayEmpty
    ' show array size
    Debug.Print "Array Size = " & UBound(MyArray)
    ' Add some values to array
    For L = 0 To UBound(MyArray)
        MyArray(L) = L
    Next L
    ' show values
    Debug.Print "Values in long array..."
    For L = 0 To UBound(MyArray)
        Debug.Print MyArray(L);
    Next L
    Debug.Print
    ' remove index 0
    If ArrayRemoveLong(MyArray, 0) = False Then
        Debug.Print
        Debug.Print "Can not remove: Index out of array bounds!"
    Else
        Debug.Print "Removed index 0, Values in array are now... "
        ' show values
        For L = 0 To UBound(MyArray)
            Debug.Print MyArray(L);
        Next L
        Debug.Print
        Debug.Print "Array Size = " & UBound(MyArray)
        Debug.Print
    End If
    Exit Sub
ArrayEmpty:
    MsgBox "Array Empty", vbInformation
End Sub

Function ArrayRemoveLong(ByRef alArray() As Long, ByVal lPos As Long) As Boolean
    '/ Remove item from Long type array //
    Dim lUBound As Long
    lUBound = UBound(alArray)
    If lPos < 0 Or lPos > lUBound Then Exit Function ' out of array bounds!
    If Not (lPos = lUBound) Then
        RtlMoveMemory VarPtr(alArray(lPos)), VarPtr(alArray(lPos + 1)), (lUBound - lPos) * 4
    End If
    If lUBound - 1 >= 0 Then
        ReDim Preserve alArray(lUBound - 1)
        ArrayRemoveLong = True
    Else
        Erase alArray()
    End If
End Function

[Merri]

ArrayRemove for any array – I guess it could be about time to optimize that function, too... it makes too many unnecessary API calls

[Edgemeal]

ArrayRemove for any array –*I guess it could be about time to optimize that function, too... it makes too many unnecessary API calls

So that func can remove multiple items in one call ay?... No looping needed.

Only thing that seems weird is the call.. ArrayRemove Not Not

[*PsyKE1*]

Thanks im going to work with very big arrays...

[Merri]

Edgemeal: yes, multiple items as long as they are continuous. The call is "weird" because it takes the pointer to safe array header. You can't declare a VB6 function As Any to get the actual array variable passed. The function supports any array: object, UDT, string, Enum, Variant, you name it

What it does is to take the pure byte data of the items to be removed, copy it into a temporary new string, move the items to be preserved and finally move the removable items to the end – and resize the array. It isn't the fastest solution possible for small arrays, but with bigger ones it is much better than any regular loop solution (especially with objects, UDTs, Variants, Strings...).

[*PsyKE1*]

Thanks really i use the Edgemeal function!

Resolved

[*PsyKE1*]

Another way to do it with Apis?

I have a problem whit Edgemeal Function:
I have in variant array this numbers:

11
12
13
14
15

call remove (2)

Private Declare Sub RtlMoveMemory Lib "Kernel32" (ByVal Destination As Any, ByVal Source As Any, ByVal length As Long)

Public Function Remove(ByVal Index As Long)
    If Index > 0 And Index < lCount Then ' lCount=Ubound(vColl)
        If Not (Index = lCount) Then
            RtlMoveMemory VarPtr(vColl(Index)), VarPtr(vColl(Index + 1)), (lCount - Index) * 4
        End If
        If lCount - 1 > 0 Then
            lCount = lCount - 1
            ReDim Preserve vColl(lCount - 1)
        Else
            Call Clear
        End If
    End If
End Function

But it returns this:

11
13
13

And gives me an error...

[Edgemeal]

And gives me an error...

All I can refer you to is the same thread Merri posted a link to above where I was asking about removing items from arrays. The code I posted above is for Longs which is why it was named "ArrayRemoveLong".

Variable Type = Byte Length
Byte = 1
Boolean = 2
Integer = 2
Long = 4
Single = 4
Double = 8
Date = 8
Variant = 16

[Merri]

Updated ArrayRemove
Better performance (less API calls), better validation, can use arrays of any base (LBound can be something else than 0).

Option Explicit

Private Declare Function ArrPtr Lib "msvbvm60" Alias "VarPtr" (Arr() As Any) As Long
Private Declare Sub PutMem4 Lib "msvbvm60" (ByVal Addr As Long, ByVal NewVal As Long)
Private Declare Function SafeArrayRedim Lib "oleaut32" (ByVal saPtr As Long, saBound As Long) As Long

Public Function ArrayRemove(ByVal NotNotArray As Long, ByVal Index As Long, Optional ByVal Items As Long = 1) As Boolean
    Dim A() As Long, AH(0 To 5) As Long, AP As Long
    Dim BSTRnull As Long, BSTRptr As Long, BSTRsize As Long
    Dim Arr As String, ArrI As Long, ArrL As Long, ArrT As String, Bounds(1) As Long
    Dim I As Long, L As Long, R As Long, S As Long
    ' IDE error fix (this will not be compiled)
    Debug.Assert App.hInstance
    ' start safe array hack
    AH(0) = 1: AH(1) = 4: AH(4) = &H3FFFFFFF
    AP = ArrPtr(A): PutMem4 AP, VarPtr(AH(0))
    ' now see if we got anything
    If (NotNotArray <> 0) And (Items > 0) Then
        ' get header information
        AH(3) = NotNotArray
        ' only allow one dimension
        If (A(0) And &HFFFF&) = 1 Then
            ' see if any data exists
            If A(3) <> 0 Then
                ' lock status
                If A(2) = 0 Then
                    ' zero base index
                    Index = Index - A(5)
                    ' cache number of items & item length in bytes
                    ArrI = A(4)
                    ArrL = A(1)
                    ' and finally we can validate index...
                    If (ArrI > Index) And (Index >= 0) Then
                        ' number of items to remove cannot exceed end of array
                        If (Index + Items) > ArrI Then
                            Items = ArrI - Index
                            If Items = 0 Then ArrI = 0
                        End If
                        ' end of array?
                        If ArrI > (Index + Items) Then
                            ' not an end of array, so we have to do some copying of data
                            L = ArrL * ArrI
                            ' items to be removed
                            R = Items * ArrL
                            ' calculate size that remains in the end
                            S = (ArrI - Index - Items) * ArrL
                            ' get BSTR pointer (= pointer to array data)
                            BSTRptr = A(3)
                            ' negative or positive pointer?
                            If BSTRptr >= 0 Then
                                ' cache old data & replace with BSTR length
                                AH(3) = BSTRptr - 4
                                BSTRsize = A(0)
                                A(0) = L
                                ' cache old data & replace with BSTR terminator
                                AH(3) = BSTRptr + L
                                BSTRnull = A(0)
                                A(0) = 0
                            Else
                                ' cache old data & replace with BSTR length
                                AH(3) = BSTRptr + 4
                                BSTRsize = A(0)
                                A(0) = L
                                ' cache old data & replace with BSTR terminator
                                AH(3) = BSTRptr - L
                                BSTRnull = A(0)
                                A(0) = 0
                            End If
                            ' point Arr to created BSTR
                            AH(3) = VarPtr(Arr): A(0) = BSTRptr
                            ' cache items to be removed
                            ArrT = MidB$(Arr, 1 + Index * ArrL, R)
                            ' now copy the end to the correct position
                            MidB$(Arr, 1 + Index * ArrL, S) = RightB$(Arr, S)
                            ' copy items to be removed to the end (this makes sure strings and objects are properly destroyed on array resize)
                            MidB$(Arr, L + 1 - R, R) = ArrT
                            ' memory clean up
                            ArrT = vbNullString
                            ' Arr no longer points to BSTR
                            A(0) = 0
                            ' negative or positive pointer?
                            If BSTRptr >= 0 Then
                                ' restore old data
                                AH(3) = BSTRptr - 4: A(0) = BSTRsize
                                AH(3) = BSTRptr + L: A(0) = BSTRnull
                            Else
                                ' restore old data
                                AH(3) = BSTRptr + 4: A(0) = BSTRsize
                                AH(3) = BSTRptr - L: A(0) = BSTRnull
                            End If
                            ' simply remove the items that are at the end of the array
                            AH(3) = NotNotArray
                            Bounds(0) = ArrI - Items
                            Bounds(1) = A(5)
                            ' true on success
                            ArrayRemove = (SafeArrayRedim(NotNotArray, Bounds(0)) = 0)
                        ElseIf ArrI > 0 Then
                            ' remove all items up to the index
                            Bounds(0) = Index
                            Bounds(1) = A(5)
                            ' true on success
                            ArrayRemove = (SafeArrayRedim(NotNotArray, Bounds(0)) = 0)
                        End If
                    End If
                End If
            End If
        End If
    End If
    ' end safe array hack
    AH(3) = AP: A(0) = 0
End Function

I know, the code is long, but without proper validation it is far too dangerous to use it.

Example

Option Explicit
' normally I don't like using this one here... but to get Array() to return an array that is one based...
Option Base 1

Private Sub Form_Load()
    Dim I As Long, Out As String, S() As Variant
    ' now create our one based array thanks to Option Base 1
    S = Array(11, 12, 13, 14, 15)
    ' then remove the second item (12)
    ArrayRemove Not Not S, 2
    ' build sample output...
    I = LBound(S)
    Out = I & " = " & S(I)
    For I = I + 1 To UBound(S)
        Out = Out & (vbNewLine & I & " = " & S(I))
    Next I
    ' show what we got
    MsgBox Out
End Sub

[*PsyKE1*]

Thank you both, are helpful...