Título: [SRC] cCollectionEx.cls
Publicado por: Psyke1 en 20 Agosto 2010, 13:36 pm
¿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: AddAdd(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. 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¡! :P
Título: Re: [SRC] cCollectionEx.cls [by *PsYkE1*]
Publicado por: Debci en 20 Agosto 2010, 13:51 pm
No uso VB pero reconozco que hay un curraco impresionante, es mas, yo hasta la pondria como funcion oficial...
Saludos
Título: Re: [SRC] cCollectionEx.cls [by *PsYkE1*]
Publicado por: Psyke1 en 20 Agosto 2010, 13:55 pm
Guau! :D Muchas gracias Debci! ;)
DoEvents¡! :P
Título: Re: [SRC] cCollectionEx.cls [by *PsYkE1*]
Publicado por: 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!¡.
Título: Re: [SRC] cCollectionEx.cls [by *PsYkE1*]
Publicado por: Psyke1 en 20 Agosto 2010, 14:40 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
Título: Re: [SRC] cCollectionEx.cls [by *PsYkE1*]
Publicado por: BlackZeroX en 20 Agosto 2010, 19:32 pm
. 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!¡.
Título: Re: [SRC] cCollectionEx.cls [by *PsYkE1*]
Publicado por: [D4N93R] en 20 Agosto 2010, 23:24 pm
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!
Título: Re: [SRC] cCollectionEx.cls [by *PsYkE1*]
Publicado por: Psyke1 en 21 Agosto 2010, 00:20 am
Gracias por las sugerencias, lo tendre en cuenta... ;)
DoEvents¡! :P
Título: Re: [SRC] cCollectionEx.cls [by *PsYkE1*]
Publicado por: Psyke1 en 22 Agosto 2010, 01:26 am
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
Título: Re: [SRC] cCollectionEx.cls [by *PsYkE1*]
Publicado por: BlackZeroX en 22 Agosto 2010, 02:44 am
Cuando una frase esta asi significa que se retiro lo dicho, pero esto no lo retiro ¬¬"
Dulces Lunas!¡.
Título: Re: [SRC] cCollectionEx.cls [by *PsYkE1*]
Publicado por: BlackZeroX en 22 Agosto 2010, 02:48 am
*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!¡.
Título: Re: [SRC] cCollectionEx.cls [by *PsYkE1*]
Publicado por: BlackZeroX en 22 Agosto 2010, 03:04 am
atendiendo tu MP *PsYkE1* loq ue hace tu Reverse es: Aplicando Reverse 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: 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 variablesi 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!¡.
Título: Re: [SRC] cCollectionEx.cls [by *PsYkE1*]
Publicado por: Psyke1 en 22 Agosto 2010, 03:06 am
Perfecto, ya te pillo... Gracias, mañana modifico, voy a la cama...
DoEvents¡! :P
Título: Re: [SRC] cCollectionEx.cls [by *PsYkE1*]
Publicado por: Di~OsK en 22 Agosto 2010, 03:10 am
GRACIAS =D
Título: Re: [SRC] cCollectionEx.cls [by *PsYkE1*]
Publicado por: BlackZeroX en 22 Agosto 2010, 03:12 am
bueno yo igual ire a terminar mi Clase de Colecciones!¡.
Hay nos vidrios
Título: Re: [SRC] cCollectionEx.cls [by *PsYkE1*]
Publicado por: Psyke1 en 22 Agosto 2010, 11:01 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
Título: Re: [SRC] cCollectionEx.cls [by *PsYkE1*]
Publicado por: BlackZeroX en 22 Agosto 2010, 19:43 pm
te falto en SwapItem, entre otros, recuerda que el ReverseMode seria Gral no solo en el de Proc Item!¡
Dulces Lunas!¡.
Título: Re: [SRC] cCollectionEx.cls [by *PsYkE1*]
Publicado por: Psyke1 en 22 Agosto 2010, 21:04 pm
Oops Gracias... ;) FAIL :xD Ahora ya esta de una vez (?) :)
DoEvents¡! :P
Título: Re: [SRC] cCollectionEx.cls
Publicado por: Psyke1 en 1 Junio 2012, 13:41 pm
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
Título: Re: [SRC] cCollectionEx.cls
Publicado por: 79137913 en 1 Junio 2012, 18:09 pm
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!!!
|