¿Todavía sigues usando
Collections?
¡¡Ahora lo que se lleva es
cCollectionEx.cls!!
Propiedades:
AddAdd(ByRef Item As Variant, Optional ByVal Index As Long)
¿A qué has adivinado que hace?
pero incluyo la opcion de insertarlo en un
Index especifico.
ContainsContains(ByRef 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 
Sorted(Optional ByVal Order As EnuListOrder = DecendentOrder) ' by BlackZeroX
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.
Aquí la clase:
Option Explicit
Option Base 1
'=====================================================================
' º Class : cCollectionEx.cls
' º Author : Psyke1
' º Mail : vbpsyke1@mixmail.com
' º Date : 17/8/10
' º Last modified : 01/06/12
' º Purpose : Replace and improve the vb6 Collection Object
' º Greets : BlackZer0x & xkiz
' º Sorted by BlackZer0x :
' http://bit.ly/M5zCKw
' º Recommended Websites :
' http://foro.h-sec.org/
' http://www.frogcheat.com.ar/
' http://infrangelux.sytes.net/
'=====================================================================
Private Declare Sub RtlMoveMemory Lib "ntdll.dll" (ByVal pDest As Long, ByVal pSrc As Long, ByVal lBytes As Long)
Public Enum EnuListOrder
AcendetOrder = 0
DecendentOrder = 1
End Enum
Private vColl() As Variant
Private lCount As Long
Private lLimit As Long
Private ReverseMode As Boolean
'// Inizialice the matrix.
Private Sub Class_Initialize()
lLimit = &H400
ReDim vColl(lLimit)
End Sub
'// It returns the number of items contained in the matrix.
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 FixIndex Index
Item = vColl(Index)
End Property
'// It returns the index of an item if exists in the matrix.
Public Function Contains(ByRef Item As Variant, Optional ByVal StartIndex As Long = 1) As Long
Dim Q As Long
If (StartIndex < lCount) And (StartIndex > 0) Then
For Q = StartIndex To lCount
If vColl(Q) = Item Then
If ReverseMode Then
Contains = lCount + 1 - Q
Else
Contains = Q
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(ByRef Item As Variant, Optional ByVal Index As Long) As Long
If IsObject(Item) = False Then
If ReverseMode Then FixIndex Index
lCount = lCount + 1
If lCount > lLimit Then
lLimit = lLimit + lLimit
ReDim Preserve vColl(lLimit)
End If
If Index > 0 And Index <= lCount Then
RtlMoveMemory VarPtr(vColl(Index + 1)), VarPtr(vColl(Index)), (lCount - Index) * 16&
Add = Index
Else
Add = lCount
End If
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 FixIndex Index
If (Index < lCount) Then
RtlMoveMemory VarPtr(vColl(Index)), VarPtr(vColl(Index + 1)), (lCount - Index) * 16&
End If
If (lCount - 1) > 0 Then
lCount = lCount - 1
Else
Clear
End If
DeleteItem = Index
End If
End Function
'// Swaps the contents of two items entering its index.
Public Function SwapItem(ByVal FirstIndex As Long, ByVal DestIndex As Long) As Long
Dim vSwap As Variant
If (FirstIndex <= lCount And FirstIndex > 0) And (DestIndex <= lCount And DestIndex > 0) And (FirstIndex <> DestIndex) Then
If ReverseMode Then
FixIndex FirstIndex
FixIndex DestinationIndex
End If
vSwap = vColl(FirstIndex)
vColl(FirstIndex) = vColl(DestIndex)
vColl(DestIndex) = vSwap
SwapItem = DestIndex
End If
End Function
'// Reverse all Items.
Public Sub Reverse()
ReverseMode = Not ReverseMode
End Sub
'// Deletes all items.
Public Sub Clear()
Erase vColl
lCount = 0&
End Sub
'// To simplify code, it's to reverse the index.
Private Sub FixIndex(ByRef lIndex As Long)
lIndex = lCount + 1 - lIndex
End Sub
'// 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
¿No crees que sea más rapido?
Pon esto en un form, añade la clase y
compílalo:
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 Sub
La diferencia suele oscilar entre los
2500/3000 ms
EDIT: He mejorado la clase, ahora será bastante mayor.DoEvents¡! 
Mostrar Temas
