[RESOLVED] Remove Item Boolean array RtlMoveMemory

[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.