[Solucionado] Como Desbloquear un Array...

[BlackZeroX]

.
Alquien sabe como solucionar esto?...

Me da el error 10: La matriz está fija o temporalmente bloqueada

Código (Vb) [Seleccionar] Expandir



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
   redim arr(0 to 5)
   arr(0) = 12
   arr(1) = 13
   arr(2) = 14
   arr(3) = 15
   arr(4) = 16
   arr(5) = 17
   RemoveInArrayLong 4, arr
End Sub

Private Function RemoveInArrayLong(ByVal Index&, ByRef ThisArray() As Long) As Boolean
Dim LenArray        As Long
Dim tArray()        As Long

   If Not (Not ThisArray) = InvalidValueArray Then
       LenArray = UBound(ThisArray) - LBound(ThisArray)
       If LenArray - 1 >= 0 Then
           If LenArray = Index& Then
               ReDim Preserve ThisArray(LBound(ThisArray) To (UBound(ThisArray) - 1))
           Else
               ReDim tArray(LenArray - 1)
               If Index > 0 Then
                   Call CopyMemory(ByVal VarPtr(tArray(LBound(tArray))), ByVal VarPtr(ThisArray(LBound(ThisArray))), 4 * Index&)
               End If
               Call CopyMemory(ByVal VarPtr(tArray(Index)), ByVal VarPtr(ThisArray(Index& + 1)), 4 * (LenArray - Index&))
               ReDim ThisArray&(LenArray - 1)
               Call CopyMemory(ByVal VarPtr(ThisArray(LBound(ThisArray))), (tArray(LBound(tArray))), 4 * LenArray)
               Erase tArray
           End If
           RemoveInArrayLong = True
       Else
           Erase ThisArray
           RemoveInArrayLong = False
       End If
   End If
End Function



Edito
.
Ojo tiene que ser via parametro el Array...

Dulces Lunas!¡.

[Miseryk]

Hola, el error 10 es porque ya dimensionaste antes el array, ej:

Esto tendrías que poner:

Código (vb) [Seleccionar] Expandir


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


Pero tu codigo sigue funcionando mal .

Asi que lo hice a mano, tal vez lo puedas mejorar o arreglar,

Código (vb) [Seleccionar] Expandir


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



Y muchas gracias por ayudarme en el otro post  , igualmente tuve una nueva duda, si puedes héchale un vistazo. 

[BlackZeroX]

.
@Miseryk

No me Sirven los For Next son tardados y lo que requiero es Velocidad a punta de derrame..

Gracias... miura ahorita ando con punteros y estructuras de variables... ya di con el problema de hecho esto me soluciona MUCHAS cosas anteriores... enseguida publico la solucion xD

Dulces Lunas!¡

[BlackZeroX]

.
Bien aquí esta la cosa... lo lamento pero estaba algo atontado con algunas cosas xP.

Código (Vb) [Seleccionar] Expandir



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



Dulce Infierno Lunar!¡.

[LeandroA]

BlackZeroX fijate que se puede eliminar sin utilizar el array temporal

Código [Seleccionar] Expandir


Function RemoveInArrayLong(ByVal Index As Long, ByRef ThisArray() As Long) As Boolean
    Dim LenArray As Long
    LenArray = UBound(ThisArray)
    If Index < 0 Or Index > LenArray Then Exit Function
    If Not (Index = LenArray) Then
        Call CopyMemory(VarPtr(ThisArray(Index)), VarPtr(ThisArray(Index + 1)), (LenArray - Index) * 4)
    End If
    If LenArray - 1 >= 0 Then
        ReDim Preserve ThisArray(LenArray - 1)
        RemoveInArrayLong = True
    Else
        Erase ThisArray()
    End If
End Function


[BlackZeroX]

.
Solo le faltaron los Byval en la linea del Copymemory.
.
Thank's... ando algo traumado ahorita son unas cosillas como esta... y andaba probando (Esto no lo sabia), por eso use Dos Arrays...

Código (Vb) [Seleccionar] Expandir



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



Dulce Infierno Lunar!¡.