Autor
Esta clase solo sive para agregar elementos y buscar dichos elementos de la manera ams rapida posible que con un simple array y un simple for next.
* Permite Agregar un array long (Se puede mejorar el algoritmo respecto a esto, pero lo deje asi.).
* Permite agregar Elementos Unicos en el momento que se desee.
* Retorna la posicion (IndexOf) si se encuentra de lo contrario retorna un valor constante INVALIDVALUEARRAY.
* Permite consultar X elemento ( GetElement).
* Permite eliminar X elemento segun su indice ( Remove(); posiblemente se tenga que buscar primero con IndexOf() ).
* Retorna la cantidad de elementos.
* Tiene una tasa de BUSQUEDA MUY RAPIDA.
Código
'
' /////////////////////////////////////////////////////////////
' // //
' // Autor: BlackZeroX ( Ortega Avila Miguel Angel ) //
' // //
' // Web: http://InfrAngeluX.Sytes.Net/ //
' // //
' // |-> Pueden Distribuir Este Codigo siempre y cuando //
' // no se eliminen los creditos originales de este codigo //
' // No importando que sea modificado/editado o engrandesido //
' // o achicado, si es en base a este codigo //
' /////////////////////////////////////////////////////////////
Option Explicit
Private lMem() As Long
Private lCount As Long
Private bDuplicate As Boolean
Public Sub clear()
Erase lMem()
lCount = 0
End Sub
Public Property Get Count() As Long
Count = lCount
End Property
' // Retorna la cantidad de elementos restantes.
Public Function Remove(ByVal lIndex As Long) As Long
Remove = RemoveInArrayLong(lIndex, lMem())
End Function
Public Property Get DuplicateElements() As Boolean
DuplicateElements = bDuplicate
End Property
Public Property Let DuplicateElements(ByVal bBool As Boolean)
bDuplicate = bBool
End Property
' // Agrega un array a la coleccion y retorna la cantidad de elementos agregados a ella.
Public Function AddArray(ByRef lArray() As Long) As Long
Dim i As Long
Dim c As Long
If Not (ItsArrayINI(VarPtrA(lArray))) Then Exit Function
c = lCount
For i = LBound(lArray()) To UBound(lArray())
Me.Add lArray(i)
Next
AddArray = (lCount - c) ' // Cantidad de elementos REALMENTE AGREGADOS: es igual a la direfencia del valor anterior y el actual de lCount.
End Function
' // Inserta en el Array el elemento Dado de manera Ascendente.
' // Agrega lVal en la coleccion de manera ordenada, y retorna el indice de su hubicacion.
' // Se retorna el indice de la hubicacion (...cambia este indice si se agrega otro y es menor a este...).
Public Function Add(ByVal lVal As Long) As Long
Dim lRetPos As Long
' // Buscamos la posicion en donde insertar...
If ExitsInArray(lVal, lMem(), lRetPos) And Not bDuplicate Then Exit Function
ReDim Preserve lMem(lCount)
lCount = (lCount + 1)
If ((lCount - 1) - lRetPos) Then ' // Recorremos a la derecha TODOS los elementos.
CopyMemory VarPtr(lMem(lRetPos + 1)), VarPtr(lMem(lRetPos)), ((lCount - lRetPos) * &H4)
End If
lMem(lRetPos) = lVal
Add = lRetPos
End Function
' // Obtenemos una copia de la coleccion de elementos.
Public Function GetArray() As Long()
GetArray = lMem()
End Function
Public Function IndexOf(ByVal lVal As Long) As Long
If Not ExitsInArray(lVal, lMem, IndexOf) Then IndexOf = INVALIDVALUEARRAY
End Function
Public Function GetElement(ByVal lIndex As Long) As Long
If (lIndex < lCount) Then GetElement = lMem(lIndex)
End Function
Private Function ExitsInArray(ByRef lVal As Long, ByRef lArray() As Long, ByRef lRetPos As Long) As Boolean
Dim lLIndex As Long
Dim lUIndex As Long
Dim iSortType As Long
If Not (ItsArrayINI(VarPtrA(lArray))) Then lRetPos = 0: Exit Function
lLIndex = LBound(lArray())
lUIndex = UBound(lArray())
If (lArray(lUIndex) < lArray(lLIndex)) Then
SwapLong lLIndex, lUIndex
iSortType = 1
End If
If (lVal < lArray(lLIndex)) Then
lRetPos = lLIndex
ElseIf (lVal = lArray(lLIndex)) Then
lRetPos = lLIndex
ExitsInArray = True
Else
If (lVal > lArray(lUIndex)) Then
lRetPos = lUIndex
ElseIf (lVal = lArray(lUIndex)) Then
lRetPos = lUIndex
ExitsInArray = True
Else
Do Until ExitsInArray
lRetPos = ((lLIndex + lUIndex) \ 2)
If ((lRetPos <> lLIndex) And (lRetPos <> lUIndex)) Then
If (lArray(lRetPos) < lVal) Then
lLIndex = lRetPos
ElseIf (lArray(lRetPos) > lVal) Then
lUIndex = lRetPos
ElseIf (lArray(lRetPos) = lVal) Then
ExitsInArray = True
End If
Else
Exit Do
End If
Loop
End If
End If
If Not (ExitsInArray) Then ' // Obtenemos la posicion donde deberia estar dicho elemento.
If (iSortType = 1) Then
If (lArray(lRetPos) > lVal) Then lRetPos = (lRetPos - 1)
Else
If (lArray(lRetPos) < lVal) Then lRetPos = (lRetPos + 1)
End If
End If
End Function
Private Sub Class_Terminate()
Call Me.clear
End Sub
En un Modulo...
Código
Option Explicit
Public Const INVALIDVALUEARRAY As Long = (-1)
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal pDest As Long, ByVal pSrc As Long, ByVal ByteLen As Long)
Public Declare Function VarPtrA Lib "msvbvm60.dll" Alias "VarPtr" (ByRef Ptr() As Any) As Long
Public Function ItsArrayINI(ByVal lngPtr As Long, Optional LnBytes As Long = 4) As Boolean
Dim lng_PtrSA As Long
If ((lngPtr <> 0) And (LnBytes > 0)) Then
Call CopyMemory(ByVal VarPtr(lng_PtrSA), ByVal lngPtr, LnBytes)
ItsArrayINI = (Not (lng_PtrSA = 0))
End If
End Function
Public Sub SwapLong(ByRef lVal1 As Long, ByRef lval2 As Long)
lval2 = lval2 Xor lVal1
lVal1 = lVal1 Xor lval2
lval2 = lval2 Xor lVal1
End Sub
' // Return (Cantidad de elementos).
Public Function RemoveInArrayLong(ByVal lIndex As Long, ByRef lArray() As Long) As Long
If (ItsArrayINI(VarPtrA(lArray)) = True) Then
RemoveInArrayLong = UBound(lArray)
If Not ((lIndex < 0) Or (lIndex > RemoveInArrayLong)) Then
If Not (lIndex = RemoveInArrayLong) Then
Call CopyMemory(ByVal VarPtr(lArray(lIndex)), ByVal VarPtr(lArray(lIndex + 1)), (RemoveInArrayLong - lIndex) * 4)
End If
If ((RemoveInArrayLong - 1) > INVALIDVALUEARRAY) Then
ReDim Preserve lArray(RemoveInArrayLong - 1)
Else
Erase lArray()
End If
End If
End If
End Function
Temibles Lunas!¡.
En línea
)
