Updated ArrayRemove
Better performance (less API calls), better validation, can use arrays of any base (LBound can be something else than 0).
I know, the code is long, but without proper validation it is far too dangerous to use it.Code: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
Example
Code: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
Reply With Quote