Aviso: Aún hay cosas a mejorar, estoy en ello... 
Y tú?¿ Todavía sigues usando
Collections?¿ {confused
Ahora lo que se lleva es
cCollectionEx.cls!! :laugh:
Hola a todos, aquí os dejo mi ultimo trabajo, estaba harto de oir:
"Las Collections son comodas pero lentas y los arrays son incomodos pero rapidos", doy las gracias a
raul338 y
ssccaann43 puesto que me han ayudado testeandolo y como no a
xkiz y
BlackZer0x que me han resuleto alguna duda que tenia por ahí...
Propiedades:
AddAdd(ByVal Item As Variant, Optional ByVal Index As Long)A que has adivinado que hace?¿ :laugh: Pero incluyo la opcion de insertarlo en un Index especifico...
ContainsContains(ByVal Item As Variant, Optional ByVal StartIndex As Long = 1)Sirve para comprbar si un Item ya esta contenido dentro de nuestra cCollectionEx, tambien puedes empezar a buscarlo desde un Index especifico
CountCount()Devuelve la cantidad de Items almacenados.
ItemItem(ByVal Index As Long)Indica el Contenido de in Item en concreto a partir de su Index.
DeleteItemDeleteItem(ByVal Index As Long)Borra un Item determinado a partir de el Index ingresado.
SwapItemSwapItem(ByVal ActualIndex As Long, ByVal DestinationIndex As Long)Intercambia dos Items...
Sorted 'De BlackZer0x Sorted(Optional ByVal Order As EnuListOrder = DecendentOrder)Ordena la cCollectionEx alfanumericamente y ademas puedes indicar el orden [descendente/ascendente]
ReverseReverse()Invierte la posicion del contenido de cCollectionEx.
ClearClear()Borra el contenido de cCollectionEx.
Aqui la clase:
'------------------------------------------------------------------------------------------------------------------
' *Class : cCollectionEx.cls
' *Author : *PsYkE1*
' *Mail : vbpsyke1@mixmail.com
' *Date : 17/8/10
' *Purpose : Replace and Improve the Collection Control
' *Greets : BlackZer0x & xkiz
' *Sorted Functions have been created by BlackZer0x
' http://foro.elhacker.net/programacion_visual_basic/source_ordenar_array_low_y_fast-t272312.0.htm
' *Recommended Websites :
' http://foro.rthacker.net/
' http://InfrAngeluX.Sytes.Net/
'------------------------------------------------------------------------------------------------------------------
Option Explicit
Option Base 1
'(* RtlMoveMemory@KERNEL32.DLL *)
Private Declare Sub RtlMoveMemory Lib "Kernel32" (ByVal Destination As Any, ByVal Source As Any, ByVal length As Long)
Enum EnuListOrder
AcendetOrder = 0
DecendentOrder
End Enum
Private vColl() As Variant
Private lCount As Long
Private ReverseMode As Boolean
'(* It returns the number of items contained in the cCollectionEx *)
Public Property Get Count() As Long
Count = lCount
End Property
'(* It returns an specific item form there Index *)
Public Property Get Item(ByVal Index As Long) As Variant
If ReverseMode Then Index = lCount + 1 - Index
Item = vColl(Index)
End Property
'(* It returns if an item is contained within the cCollectionEx *)
Public Function Contains(ByVal Item As Variant, Optional ByVal StartIndex As Long = 1) As Long
Dim x As Long
'(* I check on the bounds of my matrix *)
If (StartIndex < lCount) And (StartIndex > 0) Then
For x = StartIndex To lCount
If vColl(x) = Item Then
If ReverseMode Then
Contains = lCount + 1 - x
Else
Contains = x
End If
Exit Function
End If
Next
End If
End Function
'(* Add a new item to the cCollection, if you specify the index so you can add in a particular position *)
Public Function Add(ByVal Item As Variant, Optional ByVal Index As Long) As Long
'(* I check that the item is not an object *)
If IsObject(Item) = False Then
If ReverseMode Then Index = lCount + 1 - Index
'(* Resize my matrix *)
lCount = lCount + 1
ReDim Preserve vColl(lCount)
If Index > 0 And Index <= lCount Then
'(* I add the item in a particular index moving memory [ using RtlMoveMemory@KERNEL32.DLL ] *)
RtlMoveMemory VarPtr(vColl(Index + 1)), VarPtr(vColl(Index)), (lCount - Index) * 16&
Add = Index
Else
Add = lCount
End If
'(* I set the item *)
vColl(Add) = Item
End If
End Function
'(* Delete an specific item from its index *)
Public Function DeleteItem(ByVal Index As Long) As Long
If Index > 0 And Index <= lCount Then
If ReverseMode Then Index = lCount + 1 - Index
If Not (Index = lCount) Then
'(* Move the memory [ using RtlMoveMemory@KERNEL32.DLL ] *)
RtlMoveMemory VarPtr(vColl(Index)), VarPtr(vColl(Index + 1)), (lCount - Index) * 16&
End If
If (lCount - 1) > 0 Then
'(* Resize my matrix *)
lCount = lCount - 1
ReDim Preserve vColl(lCount)
Else
Call Clear
End If
DeleteItem = Index
End If
End Function
'(* Swaps the contents of two items entering its index *)
Public Function SwapItem(ByVal ActualIndex As Long, ByVal DestinationIndex As Long) As Long
Dim vSwap As Variant
If (ActualIndex <= lCount And ActualIndex > 0) And (DestinationIndex <= lCount And DestinationIndex > 0) And (ActualIndex <> DestinationIndex) Then
If ReverseMode Then
ActualIndex = lCount + 1 - ActualIndex
DestinationIndex = lCount + 1 - DestinationIndex
End If
vSwap = vColl(ActualIndex)
vColl(ActualIndex) = vColl(DestinationIndex)
vColl(DestinationIndex) = vSwap
SwapItem = DestinationIndex
End If
End Function
'(* Sort items alphanumerically and you can specify the order too [desdendent or ascendent] *)
Public Sub Sorted(Optional ByVal Order As EnuListOrder = DecendentOrder)
If (Not (vColl)) = -1 Then Exit Sub
Call QSort(1, lCount, Order)
End Sub
Private Sub QSort(ByVal lb As Long, ByVal ub As Long, Optional ByVal Order As EnuListOrder = DecendentOrder)
Dim k As Long
If lb < ub Then
Call PreSort(lb, ub, k, Order)
Call QSort(lb, k - 1, Order)
Call QSort(k + 1, ub, Order)
End If
End Sub
Private Sub PreSort(ByVal lb As Long, ByVal ub As Long, ByRef k As Long, Optional ByVal Order As EnuListOrder = DecendentOrder)
Dim i As Long
Dim j As Long
Dim il As Long
Dim jl As Long
il = 0: jl = -1
i = lb: j = ub
While i < j
If Order = DecendentOrder Then
If IsNumeric(vColl(i)) And IsNumeric(vColl(j)) Then
If Val(vColl(i)) > Val(vColl(j)) Then Call AuxOrden(i, j, il, jl)
Else
If vColl(i) > vColl(j) Then Call AuxOrden(i, j, il, jl)
End If
Else
If IsNumeric(vColl(i)) And IsNumeric(vColl(j)) Then
If Val(vColl(i)) < Val(vColl(j)) Then Call AuxOrden(i, j, il, jl)
Else
If vColl(i) < vColl(j) Then Call AuxOrden(i, j, il, jl)
End If
End If
i = i + il
j = j + jl
Wend
k = i
End Sub
Private Sub AuxOrden(ByVal i As Long, ByVal j As Long, ByVal il As Long, ByVal jl As Long)
Dim c As String
Dim c2 As Long
c = vColl(j)
vColl(j) = vColl(i)
vColl(i) = c
c2 = il
il = -jl
jl = -c2
End Sub
'(* Reverse all Items *)
Public Sub Reverse()
ReverseMode = Not ReverseMode
End Sub
'(* Deletes all items *)
Public Sub Clear()
Erase vColl
lCount = 0
End SubHacer asi:
Dim x As Long
For x = 1 To cTemp.Count
Debug.Print cTemp.Item(x)
Next
No crees que sea más rapido?¿ :-( Compruebalo tu mismo
:
Pon esto en un form, añade la clase, compilalo y sorprendete:
Option Explicit
Private Declare Function GetTickCount Lib "Kernel32" () As Long
' Con Collection
Public Function Check_Lucky_Number(ByVal lNumber As Long) As Boolean
Dim cTemp As New Collection
Dim NextElim As Long
Dim m As Long
Dim x As Long
If lNumber = 1 Or lNumber = 3 Then
GoTo IsLucky
ElseIf (lNumber > 1) And (lNumber Mod 2 <> 0) Then
With cTemp
For x = 1 To lNumber Step 2
.Add x
Next
NextElim = 3: m = 2
Do
x = NextElim
Do While x <= .Count
.Remove (x)
x = x + (NextElim - 1)
Loop
If .Item(.Count) = lNumber Then
m = m + 1
NextElim = .Item(m)
Else
Exit Function
End If
Loop While Not NextElim > .Count
End With
IsLucky: Check_Lucky_Number = True
End If
End Function
' Con cCollectionEx
Public Function Check_Lucky_Number2(ByVal lNumber As Long) As Boolean
Dim cTemp As New cCollectionEx
Dim NextElim As Long
Dim m As Long
Dim x As Long
If lNumber = 1 Or lNumber = 3 Then
GoTo IsLucky
ElseIf (lNumber > 1) And (lNumber Mod 2 <> 0) Then
With cTemp
For x = 1 To lNumber Step 2
.Add x
Next
NextElim = 3: m = 2
Do
x = NextElim
Do While x <= .Count
Call .DeleteItem(x)
x = x + (NextElim - 1)
Loop
If .Item(.Count) = lNumber Then
m = m + 1
NextElim = .Item(m)
Else
Exit Function
End If
Loop While Not NextElim > .Count
End With
IsLucky: Check_Lucky_Number2 = True
End If
End Function
Private Sub Form_Load()
Dim T1 As Long
Dim T2 As Long
Dim x As Long
Dim sResult As String
If App.LogMode = 0 Then
MsgBox "Prueba con proyecto compilado¡!", vbCritical
End
End If
T1 = GetTickCount
For x = 5000 To 7000
If Check_Lucky_Number(x) Then
sResult = sResult & x & " "
End If
Next
T2 = GetTickCount
MsgBox "With Collection -> " & (T2 - T1)
MsgBox sResult
'*************************************************************************
sResult = ""
'*************************************************************************
T1 = GetTickCount
For x = 5000 To 7000
If Check_Lucky_Number2(x) Then
sResult = sResult & x & " "
End If
Next
T2 = GetTickCount
MsgBox "With cCollectionEx -> " & (T2 - T1)
MsgBox sResult
End SubLa diferencia suele oscilar entre los
2500/3000 ms
Bueno, esto ha sido todo.
PD: Vivan las ranas¡!
DoEvents¡! 
Originalmente posteado
aqui...
