[RESOLVED] Remove Item Boolean array RtlMoveMemory

[Edgemeal]

I use this to remove an item from a Long type array and it works fine...

Private Sub pvArrayRemoveLong(ByRef alArray() As Long, ByVal lPos As Long)
    Dim lUBound As Long
    lUBound = UBound(alArray)
    If Not (lPos = lUBound) Then
        RtlMoveMemory VarPtr(alArray(lPos)), VarPtr(alArray(lPos + 1)), (lUBound - lPos) * 4
    End If
    ReDim Preserve alArray(lUBound - 1)
End Sub

I now need to do the same for Boolean type arrays, The code below seems to work OK, no crashes, etc, but I'm unsure its correct, I'm using *2 instead of *4 , Booleans are 2 bytes? so I use 2 here?

Private Sub pvArrayRemoveBoolean(ByRef alArray() As Boolean, ByVal lPos As Long)
    Dim lUBound As Long
    lUBound = UBound(alArray)
    If Not (lPos = lUBound) Then
        RtlMoveMemory VarPtr(alArray(lPos)), VarPtr(alArray(lPos + 1)), (lUBound - lPos) * 2
    End If
    ReDim Preserve alArray(lUBound - 1)
End Sub

[Milk]

It looks fine to me. If in doubt use Varptr to confirm the addresses...

Debug.Print VarPtr(alArray(lUBound)) - VarPtr(alArray(lPos)), (lUBound - lPos) * 2

Edit: actually you should include your declare for RtlMoveMemory, I assume it is something like...

Private Declare Sub RtlMoveMemory Lib "kernel32" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)

and not...

Private Declare Sub RtlMoveMemory Lib "kernel32" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)

[Edgemeal]

Thanks!

[Merri]

Edit! Updated version here!



If you want to work with any array, be it an array of strings, objects, classes or whatever, here is how:

Option Explicit

Private Declare Sub GetMem4 Lib "msvbvm60" (ByVal Addr As Long, RetVal As Any)
Private Declare Sub GetMem8 Lib "msvbvm60" (ByVal Addr As Long, RetVal As Any)
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 lngA As Long, lngTemp(1) As Long, strTemp As String
    Dim intHeader(0 To 1) As Integer, lngHeader(0 To 4) As Long
    Dim lngLen As Long, lngRemoved As Long, lngSize As Long, strArray As String
    ' IDE error fix (this will not be compiled)
    Debug.Assert App.hInstance
    ' now see if we got anything
    If (NotNotArray <> 0) And (Index >= 0) And (Items > 0) Then
        ' get header information
        GetMem4 NotNotArray, intHeader(0)
        ' only allow one dimension
        If intHeader(0) = 1 Then
            ' get more header information
            GetMem8 NotNotArray + 12, lngHeader(2)
            ' see if any data exists
            If lngHeader(2) Then
                ' data size information and lock status
                GetMem8 NotNotArray + 4, lngHeader(0)
                ' not locked?
                If lngHeader(1) = 0 Then
                    ' and finally we can validate index...
                    If lngHeader(3) > Index Then
                        ' get the original base information (used with SafeArrayRedim)
                        GetMem4 NotNotArray + 20, lngHeader(4)
                        ' end of array?
                        If lngHeader(3) > (Index + Items) Then
                            ' not an end of array, so we have to do some copying of data
                            lngLen = lngHeader(0) * lngHeader(3)
                            ' remember old data, replace it temporarily with string length
                            GetMem4 lngHeader(2) - 4, lngTemp(0)
                            PutMem4 lngHeader(2) - 4, lngLen
                            ' remember old data, replace it temporarily with string terminator
                            GetMem4 lngHeader(2) + lngLen, lngTemp(1)
                            PutMem4 lngHeader(2) + lngLen, 0
                            ' fake string
                            PutMem4 VarPtr(strArray), lngHeader(2)
                            ' calculate size that remains in the end
                            lngSize = (lngHeader(3) - Index - Items) * lngHeader(0)
                            ' items to be removed
                            lngRemoved = Items * lngHeader(0)
                            strTemp = MidB$(strArray, 1 + Index * lngHeader(0), lngRemoved)
                            ' now copy the end to the correct position
                            MidB$(strArray, 1 + Index * lngHeader(0), lngSize) = RightB$(strArray, lngSize)
                            ' copy items to be removed to the end (this makes sure strings and objects are properly destroyed on array resize)
                            MidB$(strArray, lngLen + 1 - lngRemoved, lngRemoved) = strTemp
                            ' end string faking
                            PutMem4 VarPtr(strArray), 0
                            ' restore old data
                            PutMem4 lngHeader(2) - 4, lngTemp(0)
                            PutMem4 lngHeader(2) + lngLen, lngTemp(1)
                            ' memory clean up
                            strTemp = vbNullString
                            ' simply remove the items
                            lngHeader(3) = lngHeader(3) - Items
                        Else
                            ' remove all items up to the index
                            lngHeader(3) = Index
                        End If
                        ' true on success
                        ArrayRemove = (SafeArrayRedim(NotNotArray, lngHeader(3)) = 0)
                    End If
                End If
            End If
        End If
    End If
End Function

The code is on a longer side, but it validates everything perfectly to avoid any crashes. I used a string hack based on another code I posted as a reply in code bank since it is faster to call VB's native string functions, but it doesn't have much effect in this case as there are only three calls (and I used a few too many PutMem and GetMem calls, but I just didn't bother to write a Type and add in the RtlMoveMemory to fill it in one go).


Sample usage:

Option Explicit

Private Sub Form_Load()
    Dim strTest() As String
    ReDim strTest(5)
    strTest(0) = "A1"
    strTest(1) = "B2"
    strTest(2) = "C3"
    strTest(3) = "D4"
    strTest(4) = "E5"
    strTest(5) = "F6"
    ' remove indexes 1, 2 and 3
    ArrayRemove Not Not strTest, 1, 3
    ' show results
    MsgBox Join(strTest)
End Sub

Note that if you change code to be a fixed array (Dim strTest(5) As String) the items to be removed are moved into the end of the array and the array does not resize.

[LaVolpe]

EdgeMeal, when not sure how many bytes a specific vartype is:

Private Sub Command1_Click()
Dim bl As Boolean, ing As Integer, lng As Long
Dim dt As Date, dbl As Double, sng As Single
Dim v As Variant, by As Byte
v = "anything"
Debug.Print LenB(bl); LenB(ing); LenB(lng); LenB(dt); LenB(dbl); LenB(sng); LenB(v); LenB(by)
End Sub

[Edgemeal]

EdgeMeal, when not sure how many bytes a specific vartype is:

Neat. I know my MSDN help has that info in there, but mainly I wasn't sure about the sub I posted.

So if I wanted to do the same thing but for an array type of Doubles I can do it like this then... ?

Private Sub pvArrayRemoveDbl(ByRef alArray() As Double, ByVal lPos As Long)
    Dim lUBound As Long
    lUBound = UBound(alArray)
    If Not (lPos = lUBound) Then
        RtlMoveMemory VarPtr(alArray(lPos)), VarPtr(alArray(lPos + 1)), (lUBound - lPos) * 8
    End If
    ReDim Preserve alArray(lUBound - 1)
End Sub

[Milk]

It will work fine providing lPos is a valid index and alArray is dynamic. You have to be careful if you do this with UDT's as they are padded to align with the largest contained data type <= 4 bytes. Lenb should always give the true size in memory.

[Merri]

The very short and scary version of what I posted earlier:

Option Explicit

Private Declare Sub RtlMoveMemory Lib "kernel32" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function SafeArrayRedim Lib "oleaut32" (ByVal saPtr As Long, saBound As Long) As Long

Private Sub pvArrayRemove(ByVal NotNotArray As Long, ByVal lPos As Long)
    Dim abTemp() As Byte, alHeader(5) As Long, lPtr As Long
    Debug.Assert App.hInstance
    RtlMoveMemory alHeader(0), ByVal NotNotArray, 24
    If Not (lPos = alHeader(4)) Then
        ReDim abTemp(alHeader(1) - 1)
        lPtr = alHeader(3) + lPos * alHeader(1)
        RtlMoveMemory abTemp(0), ByVal lPtr, alHeader(1)
        RtlMoveMemory ByVal lPtr, ByVal lPtr + alHeader(1), (alHeader(4) - lPos) * alHeader(1)
        RtlMoveMemory ByVal alHeader(3) + alHeader(4) * alHeader(1) - alHeader(1), abTemp(0), alHeader(1)
    End If
    alHeader(4) = alHeader(4) - 1
    SafeArrayRedim NotNotArray, alHeader(4)
End Sub

It copies the element to be removed, because otherwise it would cause memory leak with arrays of strings and objects.

The safe array structure provides the element size and this code thus takes advantage of that fact.

[Edgemeal]

It will work fine providing lPos is a valid index and alArray is dynamic. You have to be careful if you do this with UDT's as they are padded to align with the largest contained data type <= 4 bytes. Lenb should always give the true size in memory.

Yes all that checking is taken care of before the subs are ever called so no worries there, and for this boolean array usage its not UDT either. I just wanted to confirm I was doing it right, thanks for the replies!