[SRC] cCollectionEx.cls

[Psyke1]

¿Todavía sigues usando Collections?
¡¡Ahora lo que se lleva es cCollectionEx.cls!!



Propiedades:

Add

Código (vb) [Seleccionar] Expandir

Add(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.

Contains

Código (vb) [Seleccionar] Expandir

Contains(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.

Count

Código (vb) [Seleccionar] Expandir

Count()
Devuelve la cantidad de Items almacenados.

Item

Código (vb) [Seleccionar] Expandir

Item(ByVal Index As Long)
Indica el contenido de in Item en concreto a partir de su Index.

DeleteItem

Código (vb) [Seleccionar] Expandir

DeleteItem(ByVal Index As Long)
Borra un Item determinado a partir de el Index ingresado.

SwapItem

Código (vb) [Seleccionar] Expandir

SwapItem(ByVal ActualIndex As Long, ByVal DestinationIndex As Long)
Intercambia dos Items.

Sorted

Código (vb) [Seleccionar] Expandir

Sorted(Optional ByVal Order As EnuListOrder = DecendentOrder) ' by BlackZeroX

Ordena la cCollectionEx alfanumericamente y ademas puedes indicar el orden [descendente/ascendente].

Reverse

Código (vb) [Seleccionar] Expandir

Reverse()
Invierte la posicion del contenido de cCollectionEx.

Clear

Código (vb) [Seleccionar] Expandir

Clear()
Borra el contenido de cCollectionEx.



Aquí la clase:

Código (vb) [Seleccionar] Expandir


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:

Código (vb) [Seleccionar] Expandir

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¡!

[Debci]

No uso VB pero reconozco que hay un curraco impresionante, es mas, yo hasta la pondria como funcion oficial...

Saludos

[Psyke1]

Guau! 
Muchas gracias Debci! 

DoEvents¡!

[BlackZeroX]

.
Ojo no acepta Objetos (Form, UC, C, Class, etc...), te falto agregar el isobject en el Swapitem entre otros!¡.

Dulces Lunas!¡.

[Psyke1]

.
Ojo no acepta Objetos (Form, UC, C, Class, etc...), te falto agregar el isobject en el Swapitem entre otros!¡.

Dulces Lunas!¡.

Exacto, pero una cosa:
Porque tengo que comprobar que no sea objeto en SwapItem, si a la hora de añadir un Item no dejo que sea objeto?¿  

EDITO:
Soy tonto  entendi lo contrario, estoy trabajando en ello... 

DoEvents¡!

[BlackZeroX]

.
Te falto algo asi como un Replace ITem, un AfterItem BeforItem a la hora de agregar el Item es decir que si se desea agregar el item entre X Items, o suplantar un item por uno que no exista en la coleccion!¡.

Dulces Lunas!¡.

[[D4N93R]]

Lo vi por encima y se ve muy bien! Lo mejor es que mejoras el performance. Si tienes tiempo y si es posible, agregale algo como AddRange, para agregar otra collection a una ya existente. También un Reverse. xD no se me ocurre más nada

Saludos!

[Psyke1]

Gracias por las sugerencias, lo tendre en cuenta...

DoEvents¡!

[Psyke1]

Bueno, he añadido la funcion Reverse!
Gracias por la sugerencia [D4N93R]!

@BlackZer0x
La clase no acepta objetos, pero ¿porque dices que lo compruebe en SwapItem o en Contains si ya se que no los va ha haber, puesto que al añadirlos prescindo de los mismos?  

DoEvents¡!

[BlackZeroX]

Cuando una frase esta asi significa que se retiro lo dicho, pero esto no lo retiro ¬¬"

Dulces Lunas!¡.