¿Todavía sigues usando Collections (http://msdn.microsoft.com/es-es/library/yb7y698k(v=vs.80).aspx)? :¬¬
¡¡Ahora lo que se lleva es cCollectionEx.cls!! :laugh:
Propiedades:
Add
Add(ByRef Item As Variant, Optional ByVal Index As Long)
¿A qué has adivinado que hace? :laugh: pero incluyo la opcion de insertarlo en un Index especifico.
Contains
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
Count()
Devuelve la cantidad de Items almacenados.
Item
Item(ByVal Index As Long)
Indica el contenido de in Item en concreto a partir de su Index.
DeleteItem
DeleteItem(ByVal Index As Long)
Borra un Item determinado a partir de el Index ingresado.
SwapItem
SwapItem(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].
Reverse
Reverse()
Invierte la posicion del contenido de cCollectionEx.
Clear
Clear()
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¡! :P
No uso VB pero reconozco que hay un curraco impresionante, es mas, yo hasta la pondria como funcion oficial...
Saludos
Guau! :D
Muchas gracias Debci! ;)
DoEvents¡! :P
.
Ojo no acepta Objetos (Form, UC, C, Class, etc...), te falto agregar el isobject en el Swapitem entre otros!¡.
Dulces Lunas!¡.
Cita de: BlackZeroX en 20 Agosto 2010, 14:01 PM
.
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?¿ :huh:EDITO:Soy tonto :¬¬ entendi lo contrario, estoy trabajando en ello... ;)
DoEvents¡! :P
.
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!¡.
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!
Gracias por las sugerencias, lo tendre en cuenta... ;)
DoEvents¡! :P
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? :huh:
DoEvents¡! :P
Cuando una frase esta asi significa que se retiro lo dicho, pero esto no lo retiro ¬¬"
Dulces Lunas!¡.
*PsYkE1*
tu funcion Reverse es leeeenta, mejor en dicha funcion pon un Boolean
Public function Reverse() as boolean ' //Solo para alternar
ReverseMode= not ReverseMode
Reverse = ReverseMode
End Sub
y digamos por ejemplo en la funcion Item
Public Property Get Item(ByVal Index As Long) As Variant
if ReverseMod then index = lcount +1 - index
Item = vColl(Index)
End Property
asi no evitas el Proc que tienes.... es mas rapido aun xP
Dulces Lunas!¡.
atendiendo tu MP *PsYkE1*
loq ue hace tu Reverse es:
1,2,9,4,7,6,8
Aplicando Reverse
8,6,7,4,9,2,1
en los Indices Reales ok...
yo que yo digo es que si pones las funciones que te plasme ensima se calcula el index automaticamente sin camviar el contenido de los valores, es decir.
Teniendo esta collecion:
1,2,9,4,7,6,8
ingresamos item(1) nos devolvera 1 y si ingresamos item(3) nos devuelve 9 ok en tu Reverse se cambia el contenido en mi propuesta es que solo se altere una variable tipo Boolean de esta forma evitamos el transpaso del contenido y solamente calculamos el index segun esta variable
si item(1) antes de mi Reverse devuelve 1 e item(3) devuelve 9 con reverse (Solo alterando a la variable Boolean) se calcula que item(1) devuelve 8 e item(3) el 7 es decir:
Si ReverseMode = true entonces
Index = LCount - index +1
Fin Si
Devolver Item [ Index ]
En forma practica:
El item 1 de la colección digamos que contiene "Hola Mundo" el item 98 de la colección contiene "Dulces Lunas!¡." y en total hay 98 Items.
entonces:
Si ReverseMode = verdadero y Si y solo si Index = 1 me devuelve "Dulces Lunas!¡." pero si ReverseMode = false me devolvera "Hola Mundo".
Dulce Infierno Lunar!¡.
Perfecto, ya te pillo...
Gracias, mañana modifico, voy a la cama...
DoEvents¡! :P
GRACIAS =D
bueno yo igual ire a terminar mi Clase de Colecciones!¡.
Hay nos vidrios
Cita de: BlackZeroX en 22 Agosto 2010, 03:12 AM
bueno yo igual ire a terminar mi Clase de Colecciones!¡.
Hay nos vidrios
:o
Te odio!
Ahora me dejaras en ridiculo... :-[
Muchas gracias atodos por la ayuda :) , ahora ya esta corregido...
DoEvents¡! :P
te falto en SwapItem, entre otros, recuerda que el ReverseMode seria Gral no solo en el de Proc Item!¡
Dulces Lunas!¡.
Oops
Gracias... ;)
FAIL :xD
Ahora ya esta de una vez (?) :)
DoEvents¡! :P
Clase actualizada y mejorada, en unas horas actualizo los resultados de la diferencia de velocidad con respecto a la nativa de vb. :D
DoEvents! :P
HOLA!!!
Che, agregale una funcion "Load From File" para que levante texto delimitado.
Y si podes habilitar integridad referencial entre 2 collections seria genial.
GRACIAS POR LEER!!!