Dim arr()  As Long
 
ReDim arr(0 To 5)
 
arr(0) = 12
arr(1) = 13
arr(2) = 14
arr(3) = 15
arr(4) = 16
arr(5) = 17
 

Private Sub Form_Load()
Dim arr()  As Long
 
ReDim arr(0 To 5)
    arr(0) = 12
    arr(1) = 13
    arr(2) = 14
    arr(3) = 15
    arr(4) = 16
    arr(5) = 17
    NewRemoveInArrayLong 4, arr
End Sub
 
Private Function NewRemoveInArrayLong(ByVal Index&, ByRef ThisArray() As Long) As Boolean
Dim tArray() As Long
Dim i As Integer
 
If Not IsArray(ThisArray) Or Index& = -1 Then
    NewRemoveInArrayLong = False
    Exit Function
End If
 
If Index& = UBound(ThisArray) Then
    ReDim Preserve ThisArray(LBound(ThisArray) To (UBound(ThisArray) - 1))
 
    NewRemoveInArrayLong = True
    Exit Function
Else
    ReDim tArray(LBound(ThisArray) To (UBound(ThisArray) - 1))
    For i = LBound(ThisArray) To UBound(ThisArray)
        If i < Index& Then
            tArray(i) = ThisArray(i)
        ElseIf i > Index& Then
            tArray(i - 1) = ThisArray(i)
        End If
    Next i
    ReDim ThisArray(LBound(tArray) To UBound(tArray))
    ThisArray = tArray
    Erase tArray
 
    NewRemoveInArrayLong = True
    Exit Function
End If
NewRemoveInArrayLong = False
End Function
 
 

 
Option Explicit
 
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
        (Destination As Any, Source As Any, ByVal Length As Long)
Private Const InvalidValueArray = -1
 
Private Sub Form_Load()
Dim Arr()           As Long
Dim a               As Long
    For a = 0 To 99999  '   //  Es solo para verificar si hay Crash
        DoEvents
        ReDim Arr(0 To 5)
        Arr(0) = 12
        Arr(1) = 13
        Arr(2) = 14
        Arr(3) = 15
        Arr(4) = 16
        Arr(5) = 17
        RemoveInArrayLong 3, Arr
        Debug.Print a
    Next a
End Sub
 
Private Function RemoveInArrayLong(ByVal Index&, ByRef ThisArray() As Long) As Boolean
Dim lng_Old         As Long
Dim lng_LBound      As Long
Dim lng_UBound      As Long
Dim lng_LenArray    As Long
Dim lng_lenToCopy   As Long
Dim Arrlng_Old()    As Long
 
    If Not (Not ThisArray) = InvalidValueArray Then
        lng_LBound = LBound(ThisArray)
        lng_UBound = UBound(ThisArray)
        If Index& <= lng_UBound Then
            lng_LenArray = lng_UBound
            If lng_LBound = 0 Then lng_LenArray = lng_LenArray + 1
            If lng_LenArray > 1 Then
                lng_lenToCopy = lng_UBound - Index& - 1
                If lng_LBound = 0 Then lng_lenToCopy = lng_lenToCopy + 1
                If lng_UBound - Index& - 1 >= 0 Then
                    ReDim Arrlng_Old(lng_LBound To lng_UBound - Index& - 1)
                    Call CopyMemory(ByVal VarPtr(Arrlng_Old(lng_LBound)), _
                                    ByVal VarPtr(ThisArray(Index& + 1)), 4 * lng_lenToCopy)
                    Call CopyMemory(ByVal VarPtr(ThisArray(Index&)), _
                                    ByVal VarPtr(Arrlng_Old(lng_LBound)), 4 * lng_lenToCopy)
                End If
                ReDim Preserve ThisArray(lng_LBound To lng_UBound - 1)
                RemoveInArrayLong = True     '   // Estos son Returns que uso yo... en si son True
            Else
                Erase ThisArray
                RemoveInArrayLong = False    '   // Estos son Returns que uso yo... en si son True
            End If
        End If
    End If
End Function
 
 

 
Option Explicit
 
Enum tAlign
    Align_Left = 0
    Align_Center
    Align_Right
End Enum
 
Private Type RECTFila
    Left                                    As Long
    Top                                     As Long
    'Right                                   As Long
    Bottom                                  As Long
End Type
 
Private Type tConfigItem
    Text                                    As String
    Tag                                     As String
    Key                                     As String
    ForeColor                               As Long
    Bold                                    As Byte
    Italic                                  As Byte
    Underline                               As Byte
    Aligh                                   As tAlign
End Type
 
Private Type tConfigFilas                           '   //  Region General de las Filas.
    ToolTip                                 As String
    Tag                                     As String
End Type
 
Private Type tFilas     '   //  Region General de las Filas.
    Item                                    As tConfigItem
    SubItems()                              As tConfigItem
    ConfiguracionFila                       As tConfigFilas
    Region                                  As RECTFila
End Type
 
Dim Item(0 To 1)            As tFilas
 
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
 
Private Sub SwaptFilas(StructOrigen As tFilas, StructDest As tFilas)
Dim lng_PtrOld()                            As Byte
Dim ln_Bytes                                As Long
    ln_Bytes = LenB(StructDest)
    If ln_Bytes > 0 Then
        ReDim LHold(1 To ln_Bytes)
        CopyMemory LHold(0), ByVal VarPtr(StructOrigen), ln_Bytes
        CopyMemory ByVal VarPtr(StructOrigen), ByVal VarPtr(StructDest), ln_Bytes
        CopyMemory ByVal VarPtr(StructDest), LHold(0), ln_Bytes
    End If
End Sub
 
Private Sub Command1_Click()
    'MsgBox LenB(Item(0))
    With Item(0)
        ReDim .SubItems(20)
        MsgBox UBound(.SubItems)
        .Item.Text = "Miguel Angel"
        .Item.Tag = "Ortega Avila"
    End With
    Call SwaptFilas(Item(0), Item(1))
    Debug.Print
    With Item(1)
        MsgBox UBound(.SubItems)
        Debug.Print .Item.Text, .Item.Tag, UBound(.SubItems)
    End With
    With Item(0)
        MsgBox UBound(.SubItems)
        Debug.Print .Item.Text, .Item.Tag, UBound(.SubItems)
    End With
End Sub