Mensajes

[DoEvents¡!]

Guau! 
Muchas gracias Debci! 

DoEvents¡!

[Collections]

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

[LEE MANUALES!]

Código (vb) [Seleccionar] Expandir


    For i = LBound(x) To UBound(x)
        Msgbox x(i).sMail & " - " &  x(i).sPassword
    Next i
Me reitero en lo que te dije, LEE MANUALES!

DoEvents¡!

[Debug]

Deberias verlo en el Debug!
Claro que te tirara error, x es un array...
Si quieres entenderlo mira manuales

DoEvents¡!

[Karcrack]

Por algo Karcrack puso un ejemplo de uso...

DoEvents¡!

[DoEvents¡!]

Ya esta leandro, pedile a Tokes a ver si con su magia hace algo para optimizar

Yo lo logre con Expresiones regulares, pero, tarda un poco mas (usando FSO) y la pega es que no acepta UTF-8 directo (o sea, hay q convertir feamente u.u)

Vaya raul...
Nos quedamos sin RegExp... 

DoEvents¡!

[RegExp]

Quizas sea una chorrada, pero y si usamos RegExp?

DoEvents¡!

[Pd]

Código [Seleccionar] Expandir

Tokes: 128,759 msec
[D4N93R]: 10.388,359 msec
Raul338: 308,872 msec
Novlucker : 131,863 msec
BlackZeroX (v 2): 96,643 msec
BlackZeroX (v 3): 35,655 msec

Visual Basic sucks.. xD  

Pd: El post para meterse con VB esta aqui:
http://foro.elhacker.net/programacion_visual_basic/iquesttu_tambien_crees_que_visual_basic_es_para_tontos-t302471.0.html



DoEvents¡!  

[End Function]

Si alguien gusta hacerle alguna modiicación ¡Adelante!

Si, yo si se la voy ha hacer, aqui esta:

Código (vb) [Seleccionar] Expandir

Private Function EsNumLychrel5b(ByVal num As Long, ByRef numeroFinal As Double, Optional ByVal iteraciones As Long = 50) As Boolean
Dim n As Double, nrev As Double
   If num And &H80000000 Then Exit Function
   n = num
   Do While iteraciones > 0
       nrev = dblReverse(n)
       If n = nrev Then
           numeroFinal = n
           Exit Function
       End If
       n = n + nrev
       iteraciones = iteraciones - 1
   Loop
   nrev = dblReverse(n)
   If n = nrev Then Exit Function
   EsNumLychrel5b = True
   numeroFinal = n
End Function
Faltaba el End Function...

DoEvents¡!

[CDbl()]

Interesante, no conozco esos truquillos, supongo que es mas rapido que convertirlo con CDbl(), no?¿

DoEvents¡!