.
Alquien sabe como solucionar esto?...
Me da el error 10: La matriz está fija o temporalmente bloqueada
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!¡.
Hola, el error 10 es porque ya dimensionaste antes el array, ej:
Esto tendrías que poner:
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,
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. :laugh:
.
@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!¡
.
Bien aquí esta la cosa... lo lamento pero estaba algo atontado con algunas cosas xP.
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!¡.
BlackZeroX fijate que se puede eliminar sin utilizar el array temporal
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
.
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...
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!¡.