Temas

Hola chicos, vengo con una duda muy concreta.
¿Cómo podría conseguir el efecto que tienen las fotos de esta web?

Código [Seleccionar] Expandir

http://photodmn.com/
¿Se podría hacer con el GIMP también?

Muchas gracias

[P.A.U.]

... la P.A.U. (Prueba de Acceso Universitaria) o Selectividad o como la queráis llamar.
Quedan sólo dos días, abro este post para saber si alguien más se va a examinar en España y cómo lleva la materia.


DoEvents!

[BlackZer0x]

Bueno, cómo ahora está de moda los numeros aleatorios encontré un hueco entre mis estudios y hice esto.
Soporta divrersos tipos de arrays...(Long, Byte, Integer...).
Uso la funcion de BlackZer0x :
http://goo.gl/RG4Bx
Tuve que cambiar un par de cosas nada más para adaptarlo.

Función:

Código (vb) [Seleccionar] Expandir


Option Explicit
'======================================================================
' º Function  : LoadRndNumericArray
' º Author    : Psyke1
' º Country   : Spain
' º Mail      : vbpsyke1@mixmail.com
' º Date      : 27/05/2011
' º Twitter   : http://twitter.com/#!/PsYkE1
' º Dedicated : BlackZer0x
' º Requirements : http://goo.gl/vgbtQ || http://goo.gl/BAPXx
' º Recommended Websites :
'       http://foro.h-sec.org
'       http://www.frogcheat.com.ar
'       http://InfrAngeluX.Sytes.Net
'======================================================================
Private Declare Sub RtlMoveMemory Lib "kernel32.dll" (ByVal Destination&, ByVal Source&, ByVal Length&)

Public Static Function LoadRndNumericArray(lngMin&, lngMax&, varOutPutArr, Optional varExceptionArr) As Boolean
Dim lngTotal&, lngFinalArr&(), lngRndIndex&, Q&, C&
   If IsArray(varOutPutArr) Then
       If lngMin < lngMax Then
           lngTotal = lngMax - lngMin
           C = 0
           
           If Not IsMissing(varExceptionArr) And IsArray(varExceptionArr) Then
               Start_QuickSort varExceptionArr '// With little mod.
               
               lngTotal = lngTotal - (UBound(varExceptionArr) - LBound(varExceptionArr) + 1)
               ReDim lngFinalArr&(0 To lngTotal)
               
               '// Fix repetitions and numbers out of range.
               For Q = lngMin To lngMax
                   If IsInArray(varExceptionArr, Q, , , , True) = -1 Then
                       lngFinalArr(C) = Q
                       C = C + 1
                   End If
               Next Q
           Else
               ReDim lngFinalArr&(0 To lngTotal)

               For Q = lngMin To lngMax
                   lngFinalArr(C) = Q
                   C = C + 1
               Next Q
           End If
           
           ReDim varOutPutArr(0 To lngTotal)
           Randomize Timer
           
           For Q = 0 To lngTotal
               lngRndIndex = Rnd * lngTotal
               varOutPutArr(Q) = lngFinalArr(lngRndIndex)
               
               RtlMoveMemory VarPtr(lngFinalArr(lngRndIndex)), VarPtr(lngFinalArr(lngRndIndex + 1)), (lngTotal - lngRndIndex) * &H4
               lngTotal = lngTotal - 1
           Next Q
           
           LoadRndNumericArray = True
       End If
   End If
End Function

Ejemplo:

Código (vb) [Seleccionar] Expandir

Option Explicit
Private Declare Sub RtlMoveMemory Lib "kernel32.dll" (ByVal Destination&, ByVal Source&, ByVal Length&)

Enum EnuListOrder
   AcendetOrder = 0
   DecendentOrder = 1
End Enum

Public Static Function LoadRndNumericArray(lngMin&, lngMax&, varOutPutArr, Optional varExceptionArr) As Boolean
Dim lngTotal&, lngFinalArr&(), lngRndIndex&, Q&, C&
   If IsArray(varOutPutArr) Then
       If lngMin < lngMax Then
           lngTotal = lngMax - lngMin
           C = 0
           
           If Not IsMissing(varExceptionArr) And IsArray(varExceptionArr) Then
               Start_QuickSort varExceptionArr
               
               lngTotal = lngTotal - (UBound(varExceptionArr) - LBound(varExceptionArr) + 1)
               ReDim lngFinalArr&(0 To lngTotal)
               
               '// Fix repetitions and numbers out of range.
               For Q = lngMin To lngMax
                   If IsInArray(varExceptionArr, Q, , , , True) = -1 Then
                       lngFinalArr(C) = Q
                       C = C + 1
                   End If
               Next Q
           Else
               ReDim lngFinalArr&(0 To lngTotal)

               For Q = lngMin To lngMax
                   lngFinalArr(C) = Q
                   C = C + 1
               Next Q
           End If
           
           ReDim varOutPutArr(0 To lngTotal)
           Randomize Timer
           
           For Q = 0 To lngTotal
               lngRndIndex = Rnd * lngTotal
               varOutPutArr(Q) = lngFinalArr(lngRndIndex)
               
               RtlMoveMemory VarPtr(lngFinalArr(lngRndIndex)), VarPtr(lngFinalArr(lngRndIndex + 1)), (lngTotal - lngRndIndex) * &H4
               lngTotal = lngTotal - 1
           Next Q
           
           LoadRndNumericArray = True
       End If
   End If
End Function

'   /////////////////////////////////////////////////////////////
'   // Autor Algoritmo: C.A.R. Hoare en 1960                   //
'   // Autor:   BlackZeroX ( Ortega Avila Miguel Angel )       //
'   //                                                         //
'   // Web:     http://InfrAngeluX.Sytes.Net/                  //
'   //                                                         //
'   //    |-> Pueden Distribuir Este Codigo siempre y cuando   //
'   // no se eliminen los creditos originales de este codigo   //
'   // No importando que sea modificado/editado o engrandesido //
'   // o achicado, si es en base a este codigo                 //
'   /////////////////////////////////////////////////////////////

Private Sub AuxOrden(ByRef mArray, i As Long, j As Long, il As Long, jl As Long)
Dim C                                       As String
Dim c2                                      As Long
   C = mArray(j)
   mArray(j) = mArray(i)
   mArray(i) = C
   c2 = il
   il = -jl
   jl = -c2
End Sub

Private Sub PreSort(ByRef mArray, lb As Long, ub As Long, k As Long, Optional 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(mArray(i)) And IsNumeric(mArray(j)) Then
               If Val(mArray(i)) > Val(mArray(j)) Then
                   Call AuxOrden(mArray(), i, j, il, jl)
               End If
           Else
               If mArray(i) > mArray(j) Then
                   Call AuxOrden(mArray(), i, j, il, jl)
               End If
           End If
       Else
           If IsNumeric(mArray(i)) And IsNumeric(mArray(j)) Then
               If Val(mArray(i)) < Val(mArray(j)) Then
                   Call AuxOrden(mArray(), i, j, il, jl)
               End If
           Else
               If mArray(i) < mArray(j) Then
                   Call AuxOrden(mArray(), i, j, il, jl)
               End If
           End If
       End If
       i = i + il
       j = j + jl
   Wend
   k = i
End Sub

Private Sub QSort(ByRef mArray, lb As Long, ub As Long, _
               Optional Order As EnuListOrder = DecendentOrder)
Dim k                                   As Long
   If lb < ub Then
       PreSort mArray, lb, ub, k, Order
       Call QSort(mArray, lb, k - 1, Order)
       Call QSort(mArray, k + 1, ub, Order)
   End If
End Sub

Public Sub Start_QuickSort(ByRef mArray, Optional Order As EnuListOrder = DecendentOrder)
   QSort mArray, LBound(mArray), UBound(mArray), Order
End Sub

'// by Psyke1
Public Static Function IsInArray&(varArr, _
                                 varValue, _
                                 Optional lngStart&, _
                                 Optional lngEnd&, _
                                 Optional bolFindFirst As Boolean, _
                                 Optional bolIsSorted As Boolean)
Dim lngLB&, lngUB&, Q&, C&
   If (IsArray(varArr) = True) And (IsArray(varValue) = False) Then
       lngLB = LBound(varArr)
       lngUB = UBound(varArr)

       If Not IsMissing(lngStart) Then
          If (lngStart > lngLB) And (lngStart < lngUB) Then lngLB = lngStart
       End If
       If Not IsMissing(lngEnd) Then
          If (lngEnd > lngLB) And (lngEnd < lngUB) Then lngUB = lngEnd
       End If

       If bolIsSorted Then
           If varArr(lngLB) = varValue Then
               IsInArray = lngLB
               Exit Function
           ElseIf varArr(lngUB) = varValue Then
               If bolFindFirst Then
                   Do While (varArr(lngUB) = varArr(lngUB - 1)) And (Q > lngLB)
                       lngUB = lngUB - 1
                   Loop
               End If
               
               IsInArray = lngUB
               Exit Function
           End If

           If lngUB - lngLB < 2 Then GoTo NotFound
           If (varArr(lngLB) > varValue) Or (varArr(lngUB) < varValue) Then GoTo NotFound

           C = 0
           Do
               Q = (lngUB + lngLB) \ 2
               If C = Q Then GoTo NotFound
               
               If varArr(Q) > varValue Then
                   lngUB = Q
               ElseIf varArr(Q) < varValue Then
                   lngLB = Q
                   C = lngLB
               Else
                   If bolFindFirst Then
                       Do While (varArr(Q) = varArr(Q - 1)) And (Q > lngLB)
                           Q = Q - 1
                       Loop
                   End If
                   
                   IsInArray = Q
                   Exit Function
               End If
           Loop
       Else
           For Q = lngLB To lngUB
               If varArr(Q) = varValue Then
                   IsInArray = Q
                   Exit Function
               End If
           Next Q
           
           GoTo NotFound
       End If
   End If
Exit Function

NotFound:
   IsInArray = -1
End Function

Private Sub Form_Load()
Dim varItem, lngOut&(), intEx%(0 To 3)

   intEx(0) = -2
   intEx(1) = 1
   intEx(2) = 5
   intEx(3) = 8

   Debug.Print String$(40, "="), Time$

   If LoadRndNumericArray(-5, 10, lngOut, intEx) Then
       For Each varItem In lngOut
           Debug.Print varItem
       Next varItem
   End If
End Sub

Resultado:

Código [Seleccionar] Expandir

========================================  20:10:55
4
-4
7
3
9
-1
-5
0
10
2
6
-3

Voy a seguir estudiando para la selectividad... Bye

DoEvents!

[lngStart]

Bueno, aquí os dejo esta sencilla función.
Su finalidad es devolver el Index de un Item que se encuentre en un array (acepta todo tipo de Arrays : String, Double, Long...), con la opción de devolver el primero que se encuentre en el array y con los parámetros lngStart y lngEnd podemos establecer límites en nuestra búsqueda.  
Para ordenarlo aconsejo usar esta maravillosa función que hizo mi amigo BlackZer0x :
http://goo.gl/RG4Bx

Código (vb) [Seleccionar] Expandir

Option Explicit
'======================================================================
' º Function  : IsInArray
' º Author    : Psyke1
' º Country   : Spain
' º Mail      : vbpsyke1@mixmail.com
' º Date      : 09/05/2011
' º Twitter   : http://twitter.com/#!/PsYkE1
' º Dedicated : BlackZer0x
' º Reference : http://goo.gl/RDQhK
' º Recommended Websites :
'       http://foro.h-sec.org
'       http://www.frogcheat.com.ar
'       http://InfrAngeluX.Sytes.Net
'======================================================================
Public Static Function IsInArray&(varArr, _
                                 varValue, _
                                 Optional lngStart&, _
                                 Optional lngEnd&, _
                                 Optional bolFindFirst As Boolean, _
                                 Optional bolIsSorted As Boolean)
Dim lngLB&, lngUB&, Q&, C&
   If (IsArray(varArr) = True) And (IsArray(varValue) = False) Then
       lngLB = LBound(varArr)
       lngUB = UBound(varArr)

       If Not IsMissing(lngStart) Then
          If (lngStart > lngLB) And (lngStart < lngUB) Then lngLB = lngStart
       End If
       If Not IsMissing(lngEnd) Then
          If (lngEnd > lngLB) And (lngEnd < lngUB) Then lngUB = lngEnd
       End If

       If bolIsSorted Then
           If varArr(lngLB) = varValue Then
               IsInArray = lngLB
               Exit Function
           ElseIf varArr(lngUB) = varValue Then
               If bolFindFirst Then
                   Do While (varArr(lngUB) = varArr(lngUB - 1)) And (Q > lngLB)
                       lngUB = lngUB - 1
                   Loop
               End If
               
               IsInArray = lngUB
               Exit Function
           End If

           If lngUB - lngLB < 2 Then GoTo NotFound
           If (varArr(lngLB) > varValue) Or (varArr(lngUB) < varValue) Then GoTo NotFound

           C = 0
           Do
               Q = (lngUB + lngLB) \ 2
               If C = Q Then GoTo NotFound
               
               If varArr(Q) > varValue Then
                   lngUB = Q
               ElseIf varArr(Q) < varValue Then
                   lngLB = Q
                   C = lngLB
               Else
                   If bolFindFirst Then
                       Do While (varArr(Q) = varArr(Q - 1)) And (Q > lngLB)
                           Q = Q - 1
                       Loop
                   End If
                   
                   IsInArray = Q
                   Exit Function
               End If
           Loop
       Else
           For Q = lngLB To lngUB
               If varArr(Q) = varValue Then
                   IsInArray = Q
                   Exit Function
               End If
           Next Q
           
           GoTo NotFound
       End If
   End If
Exit Function

NotFound:
   IsInArray = -1
End Function

Un ejemplo:

Código (vb) [Seleccionar] Expandir

Option Explicit

Private Const strLine$ = "------------------------------"

Private Sub Form_Load()
Dim L&(60), S(), Q&

   For Q = 0 To 60
       L(Q) = Q * 2
   Next Q

   Debug.Print strLine$, Time$, strLine$
   Debug.Print IsInArray(L, 15)                '---> -1
   Debug.Print IsInArray(L, 40)                '--->  20
   Debug.Print IsInArray(L, 85)                '---> -1
   Debug.Print IsInArray(L, 100)               '--->  50

   S = Array("abba", "acero", "karcrack", "sereno", "silencio", "tonto", "tonto", "tonto", "tonto", "zalme")

   Debug.Print strLine$
   Debug.Print IsInArray(S, "zalme")           '--->  9
   Debug.Print IsInArray(S, "zalme", , 4)      '---> -1
   Debug.Print IsInArray(S, "mesa")            '---> -1
   Debug.Print IsInArray(S, "besos")           '---> -1
   Debug.Print IsInArray(S, "karcrack")        '--->  2
   Debug.Print IsInArray(S, "karcrack", 3)     '---> -1
   Debug.Print IsInArray(S, "tonto")           '--->  6
   Debug.Print IsInArray(S, "tonto", , , True) '--->  5
End Sub

Retorna:

Código [Seleccionar] Expandir

------------------------------            18:59:54      ------------------------------
-1
20
-1
50
------------------------------
9
-1
-1
-1
2
-1
6
5



Si necesitamos especial velocidad y lo queremos para un tipo de variable en concreto, sólo hay que modificar un par de cosas.
Aquí un ejemplo para buscar en un array Long, comparado con el código de BlackZer0x ( http://goo.gl/RDQhK ) :

Código [Seleccionar] Expandir

Option Explicit
'// Compilado sin la comprobación de límites en los arrays xP

Private Sub Form_Load()
Dim L&(6000), Q&, t As New CTiming, y&
   
   If App.LogMode = 0 Then End
   
   For Q = 0 To 6000
       L(Q) = Q * 2
   Next Q
   
   Me.AutoRedraw = True
   
   t.Reset
   For Q = 1 To 1000
       IsInArray L, 15
       IsInArray L, 40
       IsInArray L, 2001
       IsInArray L, 5020
       IsInArray L, 12000
   Next Q
   Me.Print "IsInArray", , t.sElapsed
   
   t.Reset
   For Q = 1 To 1000
       ExitsInArrayNR 15, L, y
       ExitsInArrayNR 40, L, y
       ExitsInArrayNR 2001, L, y
       ExitsInArrayNR 5020, L, y
       ExitsInArrayNR 12000, L, y
   Next Q
   Me.Print "ExitsInArrayNR", t.sElapsed
End Sub

'// by Psyke1
Public Static Function IsInArray&(lngArr&(), lngValue&, Optional lngStart&, Optional lngEnd&, Optional bolFindFirst As Boolean)
Dim lngLB&, lngUB&, lngItem&, Q&, C&
   lngLB = LBound(lngArr)
   lngUB = UBound(lngArr)
   
   If Not IsMissing(lngStart) Then
      If (lngStart > lngLB) And (lngStart < lngUB) Then lngLB = lngStart
   End If
   If Not IsMissing(lngEnd) Then
      If (lngEnd > lngLB) And (lngEnd < lngUB) Then lngUB = lngEnd
   End If
   
   If lngArr(lngLB) = lngValue Then
       IsInArray = lngLB
       Exit Function
   ElseIf lngArr(lngUB) = lngValue Then
       If bolFindFirst Then
           Do While (lngArr(lngUB) = lngArr(lngUB - 1)) And (Q > lngLB)
               lngUB = lngUB - 1
           Loop
       End If
       IsInArray = lngUB
       Exit Function
   End If
   
   If lngUB - lngLB < 2 Then GoTo NotFound
   If (lngArr(lngLB) > lngValue) Or (lngArr(lngUB) < lngValue) Then GoTo NotFound
   
   C = 0
   Do
       Q = (lngUB + lngLB) \ 2
       If C = Q Then GoTo NotFound

       If lngArr(Q) > lngValue Then
           lngUB = Q
       ElseIf lngArr(Q) < lngValue Then
           lngLB = Q
           C = lngLB
       Else
           If bolFindFirst Then
               Do While (lngArr(Q) = lngArr(Q - 1)) And (Q > lngLB)
                   Q = Q - 1
               Loop
           End If
           IsInArray = Q
           Exit Function
       End If
   Loop
Exit Function

NotFound:
   IsInArray = -1
End Function

'// by BlackZer0x
Public Function ExitsInArrayNR(ByRef vValue As Long, ByRef vBuff() As Long, ByRef p As Long) As Boolean
Dim lng_lb                      As Long
Dim lng_Ub                      As Long
   lng_lb = LBound(vBuff&())
   lng_Ub = UBound(vBuff&())
   If Not vBuff&(lng_Ub) > vBuff&(lng_lb) Then
       Dim t                           As Long
       t = lng_Ub
       lng_Ub = lng_lb
       lng_lb = t
   End If
   Do Until ExitsInArrayNR
       Select Case vValue
           Case vBuff&(lng_lb&)
               p& = lng_lb&
               ExitsInArrayNR = True
           Case vBuff&(lng_Ub&)
               p& = lng_Ub&
               ExitsInArrayNR = True
           Case Else
               p = (lng_lb& + lng_Ub&) / 2
               If p <> lng_lb& And p& <> lng_Ub& Then
                   If vBuff&(p&) < vValue& Then
                       lng_lb = p
                   ElseIf vBuff&(p&) > vValue& Then
                       lng_Ub = p
                   ElseIf vBuff&(p&) = vValue& Then
                       ExitsInArrayNR = True
                   End If
               Else
                   Exit Do
               End If
       End Select
   Loop
End Function

Resultado:


DoEvents!

[RegExp]

Hola buenas, vengo aquí con un problemilla muy sencillo que tengo con RegExp.
Necesito validar nombres de usuario que sólo pueden contener : números, letras y "_" ; tener un mínimo de un carácter y un máximo de 15.
Para ello, pensé esto:

Código [Seleccionar] Expandir

[\w_]{1,15}
El problema es que si tengo esto:

Código [Seleccionar] Expandir

=Usu@rio^
La validación me da positiva, pues, encuentra caracteres alfanuméricos...
Sólo quiero que me admita (\w y "_") nada más.
¿Me echáis una mano?
Gracias

DoEvents!

[youtube=425,350]http://www.youtube.com/watch?feature=player_embedded&v=Mg5OtXFKJoA[/youtube]
¿Alguien me podría decir de quien es la canción de este video?

Gracias

DoEvents!

Imaginemos que tengo un TextBox de una aplicación ajena a mi proyecto el cual se refresca cada cierto tiempo.
¿Hay alguna manera de saber cuando se refresca el control?
Googleé pero no encuentro la forma... Sería algo así como un Hook al control, pero según tengo entendido eso desde vb no se puede...
¿Alguna idea?

DoEvents!

[Parte 1:]

¿Qué pasa? ¿Donde están los retos que caracterizan a  esta sección?
A ver que os parece este:

Parte 1:

Crear una función que compare dos palabras (sin importar mayúsculas) y devuelva:

Código [Seleccionar] Expandir


0 : Error
1 : La 1ª palabra va antes en el abecedario
2 : La 2ª palabra va antes en el abecedario
3 : Ambas palabras son iguales

Ejemplos:

Código [Seleccionar] Expandir


"rana"        - "" -> 0
"hola"        - "holas" -> 1
"bienvenido"  - "bienvenida" -> 2
"Ejemplo"     - "eJempLIficar"  -> 2
"igual"       - "igual"         -> 3
"PALABRA"     - "palabra"       -> 3


Espero haber sido claro... Si hay alguna duda preguntad.
Por supuesto vale todo y el más rápido gana

PD: La Parte 2 la propondré cuando esté la parte 1 finalizada...

DoEvents!

Eso, una persona que creia que conocia me infecto, sinceramente no me lo esperaba de él, ni sospeche.
El caso esque empezo a manejar mi ordenador a lo lammer : escribirme cosas y tal, desconecté internét, y escaneé todo con el avast y borre todo lo que encontró. Se que el muy memo usa el Poison Ivy porque me paso una captura de pantalla. -.-
http://img42.imageshack.us/img42/6011/dibujozvw.jpg
¿Alguna sugerencia para deshacerme de este bicho? La verdad es que tengo cosas de bastante valor para mi en mi PC.
Tengo Win XP Sp3

Gracias

Tengo un archivo con un carácter extraño. Tipo : عربي...
Entonces cuando intento copiarlo a otro lugar, me da error... Nombre de archivo incorrecto... 
Alguna solucion? 

DoEvents!

[ResHack]

Hola, echando un vistazo por otro foro, vi una duda planteada y me pareció interesante.
Estoy poco puesto en malware, la pregunta es:
¿Sería posible evitar la ventana de Fabricante Desconocido al ejecutar un programa recién descargado?

¿Tal vez con ResHack se podría hacer algo?
Gracias

DoEvents!

[cFrogContest.cls]

Un reto fácil, en el que creo que puede participar mucha gente.
Consiste en obtener el nombre de archivo a partir de una ruta, así:

Código [Seleccionar] Expandir

C:\Documents and Settings\Llamazares\Mis documentos\Downloads\SexoDeRanas.avi
Deberia devolver la función:

Código [Seleccionar] Expandir

SexoDeRanas.avi

Quien sea más rápido, gana.
Se testeará con cFrogContest.cls

DoEvents!

[IIf()]

Bueno, os traigo esta simple función para reemplazar a IIf().
IIf(), es una función muy cómoda de vb, pero no es recomendable usarla en bucles o si se necesita especial agilidad porque es leeeenta.
La mía funciona exactamente igual, con la ventaja de que los argumentos en caso de ser Falso o Verdadero son opcionales.

Código (vb) [Seleccionar] Expandir

Option Explicit

Public Static Function IIfEx(ByVal bolExpresion As Boolean, _
                   Optional ByRef varTruePart As Variant, _
                   Optional ByRef varFalsePart As Variant) As Variant
   If bolExpresion Then
       IIfEx = varTruePart
   Else
       IIfEx = varFalsePart
   End If
End Function


Un pequeño ejemplo de velocidad usando CTiming.cls :

Código (vb) [Seleccionar] Expandir

Option Explicit

Private Sub Form_Load()
Dim t               As New CTiming
Dim x               As Long
Dim ret             As Variant
Const s             As String = "holaa"
Const sCorrect      As String = s
Const sIncorrect    As String = sCorrect & "a"
Const lngLoops      As Long = 100000

   If App.LogMode = 0 Then
       MsgBox "Compile it stupid!", vbCritical
       End
   End If

   Me.AutoRedraw = True
   
   Me.Print "True part"
   Me.Print
   
   t.Reset
   For x = 1 To lngLoops
       ret = IIf((s = sCorrect), 123, 1233)
   Next
   Me.Print "IIf", t.sElapsed
   
   t.Reset
   For x = 1 To lngLoops
       ret = IIfEx((s = sCorrect), 123, 1233)
   Next
   Me.Print "IIfEx", t.sElapsed
   
   Me.Print String$(20, "-")
   Me.Print "False part"
   Me.Print
   
   t.Reset
   For x = 1 To lngLoops
       ret = IIf((s = sIncorrect), 123, 1233)
   Next
   Me.Print "IIf", t.sElapsed
   
   t.Reset
   For x = 1 To lngLoops
       ret = IIfEx((s = sIncorrect), 123, 1233)
   Next
   Me.Print "IIfEx", t.sElapsed
End Sub

Resultado (IIfEx = IIIf ; que le cambié el nombre ) :




Nota: Aún así si se necesita especial velocidad mejor usar If.  

DoEvents!

[cFrogContest.cls]

Hola chicos, aqui os dejo uno de mis últimos inventos: cFrogContest.cls.
Consiste en una clase cuya finalidad es facilitar los test realizados en los retos que últimamente están tan de moda en la sección.

Consta de las siguientes carácterísticas:

• Únicamente una clase, no depende de ningún módulo ni nada más
• Muestra las funciones con llamadas erroneas
• Muestra las funciones con resultados erroneos
• Consta si fue compilado o no para hacer los test
• Las funciones deben ser públicas
• Basado en CTiming (con variantes)

Bueno aqui os dejo la clase:

Código (vb) [Seleccionar] Expandir

Option Explicit
Option Base 0
'======================================================================
' º Class      : cFrogContest.cls
' º Version    : 1.1
' º Author     : Mr.Frog ©
' º Country    : Spain
' º Mail       : vbpsyke1@mixmail.com
' º Date       : 03/02/2011
' º Last mod   : 12/02/2011
' º Twitter    : http://twitter.com/#!/PsYkE1
' º Dedicated  : Karcrack, BlackZer0x & Raul338
' º References :
'       http://www.xbeat.net/vbspeed/download/CTiming.zip
'       http://www.devx.com/tips/Tip/15422
' º Recommended Websites :
'       http://foro.h-sec.org
'       http://visual-coders.com.ar
'       http://InfrAngeluX.Sytes.Net
'======================================================================

'@oleaut32.dll
Private Declare Function SafeArrayGetDim Lib "oleaut32" (ByRef vArray() As Any) As Long
'@shlwapi.dll
Private Declare Function PathIsDirectoryA Lib "shlwapi" (ByVal pszPath As String) As Long
'@kernel32.dll
Private Declare Sub RtlMoveMemory Lib "kernel32" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As LARGE_INTEGER) As Long
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As LARGE_INTEGER) As Long
'@shell32.dll
Private Declare Function ShellExecute Lib "shell32" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Declare Function SHGetPathFromIDListA Lib "shell32" (ByVal pidl As Long, ByVal szPath As String) As Long
Private Declare Function SHGetSpecialFolderLocation Lib "shell32" (ByVal hwndOwner As Long, ByVal nFolder As Integer, ppidl As Long) As Long

'// Types
Private Type TEST_FUNCTION
   Name        As String
   Duration    As Double
End Type

Private Type LARGE_INTEGER
   LowPart     As Long
   HighPart    As Long
End Type

'// Constants
Private Const MAX_PATH                              As Long = &H100
Private Const SW_MAXIMIZE                           As Long = &H3
Private Const OVERHEAD_TEST                         As Long = &HC8
Private Const CSIDL_DESKTOP                         As Long = &H0

'// Variables
Private myFunction()                                As TEST_FUNCTION
Private dblOverHead                                 As Double
Private curTimeFreq                                 As Currency

Private oTLI                                        As Object
Private myObj                                       As Object

Private bolRet                                      As Boolean
Private bolArgs                                     As Boolean
Private bolError                                    As Boolean
Private bolReplace                                  As Boolean
Private bolNotCompiled                              As Boolean

Private lngUBRet                                    As Long
Private lngUBound                                   As Long
Private lngNumberLoops                              As Long

Private strLine                                     As String
Private strLine2                                    As String
Private strArguments                                As String
Private strFunction()                               As String
Private strDirSaveTest                              As String
Private strContestName                              As String
Private srtExplanation                              As String

Private varRet                                      As Variant
Private varResult                                   As Variant
Private varRevArgs()                                As Variant

Private liStop                                      As LARGE_INTEGER
Private liStart                                     As LARGE_INTEGER
Private liFrequency                                 As LARGE_INTEGER

'                                         ~~~~~~~> Public Properties <~~~~~~~

Friend Property Let ContestName(ByRef ContestName As String)
   strContestName = ContestName
End Property

Friend Property Let Explanation(ByRef Explanation As String)
   srtExplanation = Explanation
End Property

Friend Sub SetObject(OneObject As Object)
   Set myObj = OneObject
End Sub

Friend Sub Functions(ByRef Functions As String, Optional ByRef Delimiter As String = ",")
'------------------------------------------------
' * Important : All the functions must be public.
'------------------------------------------------
   strFunction = Split(Functions, Delimiter)
   lngUBound = UBound(strFunction)
End Sub

Friend Sub Arguments(ParamArray Arguments() As Variant)
Dim lngTotalItems                                   As Long
Dim Q                                               As Long

   If Not IsMissing(Arguments) Then
       lngTotalItems = UBound(Arguments)
       strArguments = Join$(Arguments, ", ")

       ReDim varRevArgs(lngTotalItems) As Variant
       For Q = 0 To lngTotalItems
           varRevArgs(Q) = Arguments(lngTotalItems - Q)
       Next Q

       bolArgs = True
   End If
End Sub

Friend Property Let ReplaceFile(ByVal ReplaceIt As Boolean)
   bolReplace = ReplaceIt
End Property

Friend Property Let NumberOfLoops(ByVal Times As Long)
   lngNumberLoops = Times
End Property

Friend Property Let Result(ByRef Result As Variant)
'---------------------------------------------------------------------
' * Important : It doesn't support multidimensional arrays or objects.
'---------------------------------------------------------------------
Dim lngLBound                                       As Long
Dim Q                                               As Long

   Select Case VarType(Result)
       Case vbDataObject, vbEmpty, vbNull, vbObject, vbUserDefinedType
           Exit Property
       Case Else
           If IsArray(Result) Then
               lngUBRet = UBound(Result)

               If VarType(Result) = vbArray + vbString Then
                   varResult = Join$(Result)
               Else
                   lngLBound = LBound(Result)
                   If lngLBound Then
                       lngUBRet = lngUBRet - lngLBound
                       ReDim varResult(lngUBRet) As Variant
                       
                       For Q = 0 To lngUBRet
                           varResult(Q) = Result(Q + lngLBound)
                       Next Q
                   Else
                       varResult = Result
                   End If
               End If
           Else
               varResult = Result
           End If
   End Select

   bolRet = True
End Property

Friend Property Let SaveDirectory(ByRef DirPath As String)
   If PathIsDirectoryA(DirPath) Then
       strDirSaveTest = DirPath
   Else
       strDirSaveTest = GetDesktopPath
   End If

   If Not (Right$(strDirSaveTest, 1) = "\") Then
       strDirSaveTest = strDirSaveTest & "\"
   End If
End Property

'                                   ~~~~~~~> Public Functions & Procedures <~~~~~~~

Friend Sub TestIt()
Dim dblTmpDuration                                  As Double
Dim colError                                        As New Collection
Dim colErrCall                                      As New Collection
Dim strFName                                        As String
Dim bolWrong                                        As Boolean
Dim ff                                              As Integer
Dim Q                                               As Long
Dim C                                               As Long

   If SafeArrayGetDim(strFunction) And Not (myObj Is Nothing) Then
       If LenB(strContestName) = 0 Then strContestName = "Test"
       If LenB(srtExplanation) = 0 Then srtExplanation = "-"
       If lngNumberLoops < 1 Then lngNumberLoops = 1

       For Q = 0 To lngUBound
           strFName = strFunction(Q)

           ResetTimer
           varRet = CallByNameEx(strFName)
           dblTmpDuration = GetTiming

           If bolRet Then
               bolWrong = IsWrongResult
           End If

           If bolWrong Or bolError Then
               If bolError Or (bolWrong And bolError) Then
                   bolError = False
                   colErrCall.Add strFName
                   Debug.Print "Error Call :", strFName
               ElseIf bolWrong Then
                   colError.Add strFName
                   Debug.Print "Error result :", strFName
               End If

               lngUBound = lngUBound - 1
               If lngUBound = -1 Then GoTo JumpSpeedTest
           Else
               ReDim Preserve myFunction(C) As TEST_FUNCTION

               With myFunction(C)
                   .Name = strFName
                   .Duration = dblTmpDuration
               End With

               C = C + 1
           End If
       Next Q

       If lngNumberLoops > 1 Then
           For Q = 0 To lngUBound
               With myFunction(Q)
                   ResetTimer
                   For C = 2 To lngNumberLoops
                       CallByNameEx .Name
                   Next C
                   .Duration = GetTiming + .Duration
               End With
           Next Q
       End If

       Call BubbleSort

JumpSpeedTest:

       strDirSaveTest = Left$(strDirSaveTest, InStrRev(strDirSaveTest, "\"))
       strDirSaveTest = strDirSaveTest & strContestName & ".txt"
       ff = FreeFile

       If bolReplace Then
           Open strDirSaveTest For Output As #ff
       Else
           Open strDirSaveTest For Append As #ff
       End If

           Print #ff, strLine
           Print #ff, "º Contest Name : "; strContestName
           Print #ff, "º Explanation  : "; srtExplanation
           Print #ff, "º Arguments    : "; strArguments
           Print #ff, "º Loops        : "; CStr(lngNumberLoops)
           Print #ff, "º Date & Hour  : "; Date$; " <-> "; Time$
           Print #ff, strLine

           If lngUBound > -1 Then
               Print #ff, "Results "; IIf(bolNotCompiled, "[not ", "["); "compiled] :"
               Print #ff, strLine2
           
               For Q = 0 To lngUBound
                   With myFunction(Q)
                       Print #ff, CStr(Q + 1); ".- "; .Name, , , "-> "; Format$(.Duration * 1000, "#0.000000"); " msec"
                   End With
               Next Q
           End If

           With colErrCall
               If .Count Then
                   Print #ff, strLine
                   Print #ff, "º The following calls are wrong :"
                   Print #ff, strLine2
                   
                   For Q = 1 To .Count
                       Print #ff, CStr(Q); ".- "; .Item(Q)
                   Next Q
               End If
           End With

           With colError
               If bolRet And .Count Then
                   Print #ff, strLine
                   Print #ff, "º The following functions returns incorrect results :"
                   Print #ff, strLine2
                   
                   For Q = 1 To .Count
                       Print #ff, CStr(Q); ".- "; .Item(Q)
                   Next Q
               End If
           End With

           Print #ff, strLine
           Print #ff, ">>> Test made by cFrogContest.cls <-> Visit foro.elhacker.net <<<"
           Print #ff, strLine; vbCrLf
       Close #ff
   End If
End Sub

Friend Function ShowTest() As Long
   ShowTest = ShellExecute(0, "Open", strDirSaveTest, vbNullString, vbNullString, SW_MAXIMIZE)
End Function

'                                 ~~~~~~~> Private Functions & Procedures <~~~~~~~

Private Function CallByNameEx(ByRef strProcName As String) As Variant
Dim ProcID                                          As Long

   On Error GoTo Error_
   ProcID = oTLI.InvokeID(myObj, strProcName)
   If bolArgs Then
       CallByNameEx = oTLI.InvokeHookArray(myObj, ProcID, VbMethod, varRevArgs)
   Else
       CallByNameEx = oTLI.InvokeHook(myObj, ProcID, VbMethod)
   End If
Exit Function

Error_:
   bolError = True
End Function

Private Function IsWrongResult() As Boolean
Dim lngLBound                                       As Long
Dim Q                                               As Long

   If VarType(varRet) And vbArray Then
       lngLBound = LBound(varRet)
       If UBound(varRet) - lngLBound = lngUBRet Then
           If VarType(varRet) = vbArray + vbString Then
               IsWrongResult = (varResult = Join$(varRet))
           Else
               For Q = 0 To lngUBRet
                   IsWrongResult = (varRet(Q + lngLBound) = varResult(Q))
                   If IsWrongResult Then Exit Function
               Next Q
           End If
       End If
   Else
       IsWrongResult = (varResult = varRet)
   End If

   IsWrongResult = Not IsWrongResult
End Function

Private Sub BubbleSort()
Dim SwapItem                                        As TEST_FUNCTION
Dim lngLimit                                        As Long
Dim Q                                               As Long
Dim C                                               As Long

   lngLimit = lngUBound - 1
   For Q = 0 To lngLimit
       For C = 0 To lngLimit
           If myFunction(C).Duration > myFunction(C + 1).Duration Then
               SwapItem = myFunction(C)
               myFunction(C) = myFunction(C + 1)
               myFunction(C + 1) = SwapItem
           End If
       Next C
   Next Q
End Sub

Private Function GetDesktopPath() As String
Dim lPidl                                           As Long

   GetDesktopPath = String$(MAX_PATH, vbNullChar)
   SHGetSpecialFolderLocation &H0, CSIDL_DESKTOP, lPidl
   SHGetPathFromIDListA lPidl, GetDesktopPath
   GetDesktopPath = Left$(GetDesktopPath, InStrB(GetDesktopPath, vbNullChar) \ 2)
End Function

Private Sub ResetTimer()
   QueryPerformanceCounter liStart
End Sub

Private Function GetTiming() As Double
   QueryPerformanceCounter liStop
   GetTiming = (LrgIntToCur(liStop) - LrgIntToCur(liStart) - dblOverHead) / curTimeFreq
End Function

Private Function LrgIntToCur(liInput As LARGE_INTEGER) As Currency
   RtlMoveMemory LrgIntToCur, liInput, LenB(liInput)
End Function

Private Sub Class_Initialize()
Dim Q                                               As Long

   bolNotCompiled = (App.LogMode = 0)
   If QueryPerformanceFrequency(liFrequency) = 0 Then
       MsgBox "This PC doesn't support high-res timers", vbCritical, "Fatal Error"
       End
   ElseIf bolNotCompiled Then
       MsgBox "Compile it to get real results!", vbCritical, "Advice"
   End If

   ResetTimer
   For Q = 1 To OVERHEAD_TEST
       QueryPerformanceCounter liStop
   Next Q
   dblOverHead = (LrgIntToCur(liStop) - LrgIntToCur(liStart)) / OVERHEAD_TEST

   Set oTLI = CreateObject("TLI.TLIApplication")
   strLine = String$(80, "=")
   strLine2 = String$(80, "~")
   curTimeFreq = LrgIntToCur(liFrequency)

   Debug.Print ">>> Class cFrogContest.cls initiated at " & Time$ & " <<<"
End Sub

Descargar cFrogContest.cls

Aqui os dejo un ejemplo de uso, usando todas las propiedades y funciones:

Código (vb) [Seleccionar] Expandir

Option Explicit

'@kernel32
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private cFC                     As New cFrogContest '// Class declaration.

'~~~~~~~> Functions to test.
Public Function VerySlow(ByVal lngArg1 As Long, ByVal strArg2 As String) As Long
   Sleep 4
   VerySlow = 2
End Function

Public Function Slow(ByVal lngArg1 As Long, ByVal strArg2 As String) As Long
   Sleep 2
   Slow = 2
End Function

Public Function Quick(ByVal lngArg1 As Long, ByVal strArg2 As String) As Long
   Sleep 1
   Quick = 2
End Function

Public Function VeryQuick(ByVal lngArg1 As Long, ByVal strArg2 As String) As Long
   VeryQuick = 3                                   '// I put a different result on purpose. xP
End Function

'~~~~~~~> Example of use.
Private Sub Form_Load()
   With cFC
       .ContestName = "Test1"                      '// The constest name.
       .Explanation = "It's only a simple test..." '// Little explanation.
       .SaveDirectory = "c:\"                      '// Directory where you saved the test.
       .ReplaceFile = False                        '// To overwrite the file.
       .Functions "VerySlow,VeryQuick,Slow,Quick"  '// Name of the functions.
       .Arguments 20, "Long life to Frogs!"        '// Arguments of functions (must be the same in all functions).
       .NumberOfLoops = 100                        '// Number of Loop to call them.
       .Result = 2                                 '// This result should give functions.
       .SetObject Me                               '// Object (needed to make the calls).
       .TestIt                                     '// Execute the test and save it.
       .ShowTest                                   '// Shows the txt file.
   End With

   End                                             '// Exit.
End Sub

Este es el resultado que aparece en el txt:

Código [Seleccionar] Expandir

================================================================================
º Contest Name : Test1
º Explanation  : It's only a simple test...
º Arguments    : 20, Long life to Frogs!
º Loops        : 100
º Date & Hour  : 02-12-2011 <-> 22:25:05
================================================================================
Results [not compiled] :
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1.- Quick                                 -> 193,846610 msec
2.- Slow                                  -> 292,967082 msec
3.- VerySlow                              -> 490,423567 msec
================================================================================
º The following functions returns incorrect results :
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1.- VeryQuick
================================================================================
>>> Test made by cFrogContest.cls <-> Visit foro.elhacker.net <<<
================================================================================

También se podría hacer esto:

Código (vb) [Seleccionar] Expandir


'...
'~~~~~~~> Example of use.
Private Sub Form_Load()
   With cFC
       .ContestName = "Test1"                      '// The constest name.
       .Explanation = "It's only a simple test..." '// Little explanation.
       .SaveDirectory = "c:\"                      '// Directory where you saved the test.
       .ReplaceFile = False                        '// To overwrite the file.
       .Functions "VerySlow,VeryQuick,Slow,Quick"  '// Name of the functions.
       .Arguments 20, "Long life to Frogs!"        '// Arguments of functions (must be the same in all functions).
       .NumberOfLoops = 100                        '// Number of Loop to call them.
       .Result = 2                                 '// This result should give functions.
       .SetObject Me                               '// Object (needed to make the calls).
       .TestIt                                     '// Execute the test and save it.
       
       .Explanation = "Second test"
       .Result = 3
       .Arguments 34, "It works good"
       .ShowTest                                   '// Shows the txt file.
   End With

   End                                             '// Exit.
End Sub

Así podemos hacer varios test de una sola vez...

Esto es todo, espero que os haya gustado.
Estoy abierto a nuevas ideas y recomendaciones.

DoEvents!

[seba123neo]

Hola chicos:
Está a la vista que seba123neo [moderador de vb] no está muy activo que digamos, al menos en su sección correspondiente.
Cada dos por tres postea gente en Visual Basic que se equivoca de sección o hay comentarios inapropiados, temas que no llevan a ningún lado...
Yo reporto algunos casos, pero aún así, no creo que sea la solución.
Por tanto sugiero añadir otro moderador más a la sección.
Es solo mi opinión ¿que opinais? (sobretodo el staff  )

DoEvents!

¿Alguien sabría decirme el nombre de ese muñeco marrón?


Gracias

[LordRNA]

... 
Como siga aqui LordRNA...
Hoy es su cupleaños y aunque seas el mayor troll que conozco te felicito!



DoEvents!

[Instr()]

Bueno, pues eso, para empezar el año con buen pie propongo este reto, consiste en crear una función que haga lo mismo que Instr().
(En principio sin contar con métodos de compración)
Si hay dudas postear.



DoEvents!

Alguien me puede explicar el comando Mssgbox? (se escribe asi?)
Gracias por adelantado

Pido consejo:

Estoy buscando un shooter online en primera persona que sea fácil de instalar, que no requiera un PC muy potente, y que sea sencillo crear una partida online para jugar con mis amigos.

Gracias

Os dejo mi ultima clase que sirve para justificar texto en un ListBox, la novedad es que puedes actuar sobre especificamente con cada Item, dejo el código:

Código (vb) [Seleccionar] Expandir

Option Explicit
'==================================================================================================
' º Class     : MultiAlignListBox.cls
' º Version   : 1.1
' º Author    : Mr.Frog ©
' º Country   : Spain
' º Mail      : vbpsyke1@mixmail.com
' º Date      : 14/12/2010
' º Twitter   : http://twitter.com/#!/PsYkE1
' º Tested on : WinXp & Win7
' º Greets    : LaVolpe & Raul338 & BlackZer0x & Karmany
' º Reference : http://www.elguille.info/colabora/vb2006/karmany_centrartextolistbox.htm
' º Recommended Websites :
'       http://visual-coders.com.ar
'       http://InfrAngeluX.Sytes.Net
'==================================================================================================

Private Declare Function GetDialogBaseUnits Lib "user32" () As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hDC As Long, ByVal lpString As String, ByVal cbString As Long, lpSize As SIZE) As Long

Private Type RECT
   Left    As Long
   Top     As Long
   Right   As Long
   Bottom  As Long
End Type

Private Type SIZE
   cX      As Long
   cY      As Long
End Type

Private Const LB_SETTABSTOPS                        As Long = &H192&
Private Const WM_GETFONT                            As Long = &H31&

Private Const CHARS_LIST                            As String = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890"
Private Const CHARS_LEN                             As Long = &H3E&

Private myListBox                                   As ListBox
Private lListhWnd                                   As Long
Private lWidth                                      As Long

Public Sub SetListBox(myList As ListBox)
   If Not (myList Is Nothing) Then
       Set myListBox = myList
       lListhWnd = myListBox.hwnd
       SetRightTab
   End If
End Sub

Public Sub AddAlignItem(ByVal Item As String, ByVal Align As AlignmentConstants, Optional ByVal Index As Long = (-1))
Dim lCenterAlign                                    As Long

   With myListBox
       lCenterAlign = Int(.Width - PixelsPerUnit(Item))
       If lCenterAlign < 0 Then Align = vbLeftJustify
       
       If Index = (-1) Then Index = .ListCount
       
       Select Case Align
           Case vbRightJustify
               .AddItem vbTab & Item, Index
               If Not (lWidth = GetListSize) Then SetRightTab
           Case vbCenter
               .AddItem Space$(Abs(Int(lCenterAlign / PixelsPerUnit(Space$(1)) / 2) - 1.5)) & Item, Index
           Case Else
               .AddItem Item, Index
       End Select
   End With
End Sub

Public Sub ChangeListBoxAlign(Optional ByVal Index As Long = (-1), Optional ByVal Align As AlignmentConstants = vbAlignLeft)
Dim Q                                               As Long

   If Index > -1 Then
       SetAlign Index, Align
   Else
       For Q = 0 To (myListBox.ListCount - 1)
           SetAlign Q, Align
       Next Q
   End If
End Sub

Public Function GetItem(ByVal Index As Long) As String
   GetItem = LTrim$(myListBox.List(Index))
   
   If (GetItem Like (vbTab & "*")) Then
       GetItem = Right$(GetItem, (Len(GetItem) - 1))
   End If
End Function

Private Sub SetAlign(ByVal Index As Long, ByVal Align As AlignmentConstants)
Dim sItem                                           As String

   With myListBox
       sItem = GetRealItem(Index)
       If Not (.List(Index) = sItem) Then
           .RemoveItem (Index)
           AddAlignItem sItem, Align, Index
       End If
   End With
End Sub

Private Sub SetRightTab()
Dim lRightAlignTab                                  As Long

   lWidth = GetListSize
   lRightAlignTab = -(lWidth / PixelsPerUnit)
   
   SendMessage lListhWnd, LB_SETTABSTOPS, &H0&, ByVal &H0&
   SendMessage lListhWnd, LB_SETTABSTOPS, &H1&, lRightAlignTab
   
   myListBox.Refresh
End Sub

Private Function GetListSize() As Long
Dim RCT                                             As RECT

   GetClientRect lListhWnd, RCT
   With RCT
       GetListSize = (.Right - .Left)
   End With
End Function


Private Function PixelsPerUnit(Optional ByVal sText As String) As Single
Dim hDC                                             As Long
Dim hFont                                           As Long
Dim hFontOld                                        As Long
Dim SZ                                              As SIZE

   hDC = GetDC(lListhWnd)
   If CBool(hDC) = True Then
       hFont = SendMessage(lListhWnd, WM_GETFONT, &H0&, ByVal &H0&)
       hFontOld = SelectObject(hDC, hFont)
       
       If sText = vbNullString Then
           If GetTextExtentPoint32(hDC, CHARS_LIST, CHARS_LEN, SZ) Then
               PixelsPerUnit = CSng((2 * CLng(SZ.cX / CHARS_LEN)) / (GetDialogBaseUnits And &HFFFF&))
           End If
       Else
           If GetTextExtentPoint32(hDC, sText, Len(sText), SZ) Then
               PixelsPerUnit = (SZ.cX * Screen.TwipsPerPixelX)
           End If
       End If
       
       SelectObject hDC, hFontOld
       ReleaseDC lListhWnd, hDC
   End If
End Function

Private Sub Class_Initialize()
   Debug.Print "--> cListBoxMultiAlign.cls By Mr.Frog © <--"
End Sub

Una imagen vale mas que 1000 palabras:

DoEvents!

Me encontre con estas constantes para alinear un ListBox e hice esta sencilla función, poner en un módulo:
Solo incluyo alineamiento de items a la derecha e izquierda, porque para centrarlos hay que hacerlo de forma diferente.
Posteado en http://www.visual-coders.com.ar/

Código (vb) [Seleccionar] Expandir

Option Explicit
'=========================================================
' º Function : AlignListBox
' º Author   : Mr. Frog ©
' º Mail     : vbpsyke1@mixmail.com
' º Recommended Websites :
'       http://visual-coders.com.ar
'       http://InfrAngeluX.Sytes.Net
'       http://twitter.com/#!/PsYkE1
'=========================================================

Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Private Const GWL_EXSTYLE                       As Long = (-20)
Private Const WS_EX_RIGHT                       As Long = &H1000&
Private Const WS_EX_LEFT                        As Long = &H0&
Private Const WS_EX_LEFTSCROLLBAR               As Long = &H4000&
Private Const WS_EX_RIGHTSCROLLBAR              As Long = &H0&

Public Enum AlignConstants
  aLeft = 0
  aRight = 1
End Enum

Public Enum OptionAlign
  Items = 0
  ScollBar = 1
End Enum

Public Function AlignListBox(ByVal myListBox As ListBox, _
                              ByVal ThingToAlign As OptionAlign, _
                              Optional ByVal Align As AlignConstants = aLeft) As Long
Dim lStyle                                              As Long
Dim lHwnd                                               As Long
   If Not (myListBox Is Nothing) Then
       lHwnd = myListBox.hwnd
       lStyle = GetWindowLong(lHwnd, GWL_EXSTYLE)
       If Align = aRight Then
           If ThingToAlign = Items Then
               lStyle = lStyle Or WS_EX_RIGHT
           Else
               lStyle = lStyle And WS_EX_RIGHTSCROLLBAR
           End If
       Else
           If ThingToAlign = Items Then
               lStyle = lStyle And WS_EX_LEFT
           Else
               lStyle = lStyle Or WS_EX_LEFTSCROLLBAR
           End If
       End If
       AlignListBox = SetWindowLong(lHwnd, GWL_EXSTYLE, lStyle)
   End If
End Function

Ejemplo:

Código (vb) [Seleccionar] Expandir

Option Explicit

Private Sub Form_Load()
Dim Q                               As Long
   For Q = 0 To (Screen.FontCount - 1)
       List1.AddItem Screen.Fonts(Q)
   Next Q
   
   AlignListBox List1, Items, aRight
   'AlignListBox List1, Items, aLeft
   AlignListBox List1, ScollBar, aLeft
   'AlignListBox List1, ScollBar, aRight
End Sub

Resultado:

DoEvents!

Hola buenas, estoy intentando crear un server para el Left 4 Dead No Steam, he googleado y me he bajado unos parches, ademas ponia que tenia que usar Garena. (Según esto : http://www.taringa.net/posts/juegos/5682254/tutorial-para-jugar-al-left-4-dead-online-y-crear-partidas.html)
Me baje el programa de Garena, me registre, pero dice que es imposible conectar con el servidor...
Si alguien sabe que puede ocurrir o lo ha conseguido de otra manera agradecería su ayuda.

DoEvents!

[FrogCheat v1.1]

Hola a todos, os presento uno de mis últimos proyectos : FrogCheat v1.1.
Es un Cheat para los shooters (juegos de disparar).
Al principio empezó siendo la segunda versión de el NRC v1.0.
(Esta versión ha sido presentada con prisas para entregarlo dentro de la fecha del concurso de programación de elhacker.net, asi que es posible que tenga algún pequeño error)

1.- Estabiliza el arma al disparar, todo ello con un nivel de intensidad modificable y la posibilidad de tener dos niveles diferentes guardados (arma primaria y arma secundaria).
2.- Dibuja una mirilla estatica la cual aporta mayor precisión a el usuario a la hora de apuntar (disponibles tres modelos: Circular, cruz, equis ; con la posibilidad de elegir hasta entre ocho colores diferentes).  
   * Nota importante: Para poder disfrutar de esta opción debes jugar en modo ventana (soporta OpenGl  ).
3.- Teclas de acceso rápido para habilitar/deshabilitar la mirilla/NoRecoil asi como el valor de éste (Las teclas pueden ser cambiadas por el usuario).  
4.- Una voz te informara de las opciones que habilites/deshabilites y tambien el nivel de NoRecoil actual... (la voz se puede deshabilitar en la sección de configuración)
5.- Alto nivel de compatibilidad, ha sido testeado en varios juegos y en varios SO.
6.- Tengo el orgullo de poder decir que es 100% indetectable (puesto que no actuo directamente sobre el proceso del juego)
7.- Es totalmente portable, no requiere instalación, ni depende de ningún OCX ni libreria adicional.

Bueno, aqui hay algunas capturas que los testers y yo hemos ido tomando para que os hagais una idea de la mirilla estática :

Counter Strike 1.6
Gears of War
Left 4 Dead

Un video-tutorial que hizo VanHan para que veais como va la cosa :

[youtube=425,350]http://www.youtube.com/watch?v=GGCjkfRLAQk[/youtube]

* Autor : Mr. Frog ©
* Excelente diseño  : VanHan
* Agradecimientos  : Raul338 & BlackZer0x & Dessa & LeandroA
* Testers (los más pacientes ) : Guru6 & Elemental Code & aaronduran2 & VanHan & _kazte_



Esto es todo, espero que os guste, y si así es, no lo dudes y dejame tu voto en el concurso de programación.
Ir al hilo de votaciones del concurso de programación de elhacker.net

Gracias, aqui puedes descargar el código fuente + proyecto compilado

La web del proyecto es http://frogcheat.com.ar/

DoEvents!



No os lo vais a creer, me han copiado la idea!!!  
http://goo.gl/pEHMk

En fin...

[EDIT]

Bueno, aqui traigo un reto bastante fácil digo yo, la idea es armar una matriz de las dimensiones indicadas siguendo las explicaciones:

Si introduzco 5 en la función:

0     1     2     3     4    
1     3     5     7     4    
9    15    16    7     4    
47   42    16    7    4    
116   42    16    7    4

Cada numero viene dado de la suma del que tenga arriba mas tantas columnas a la derecha como el numero fila actual.
En caso de sobrepasar el limite de columnas es igual a el numero de arriba.
Si no me explico bien postea o mándame un MP.

El reto ha sido pensado por mi...

Mucha suerte, yo me pongo ya a hacerlo!!

DoEvents!

EDIT: Ya lo tengo, mañana posteo...

Aqui os dejo esto que hice para un amigo, por si a alguien le sirve:
http://goo.gl/fOGeE

DoEvents!

[youtube=425,350]http://www.youtube.com/watch?v=MsnAKr5RqBU[/youtube]
[youtube=425,350]http://www.youtube.com/watch?v=62Ku_UTBkPY[/youtube]
[youtube=425,350]http://www.youtube.com/watch?v=mU6UkIa8MM0&feature=related[/youtube]
Jajajajajaja
Lo malo es que es veridico...

DoEvents!

Igual es una tonteria pero no tengo la opcion de poner el texto debajo del nick (Título Personalizado)


Gracias por la ayuda!

DoEvents!

Hola, un amigo mio esta convencido de que esto:
http://cleverbot.com/ No es un bot en realidad, a pesar de lo que pone en esa misma pagina (traducido):

NOTA: Cleverbot aprende de la gente real - las cosas que dice puede parecer inapropiado - el uso con discreción, y en SU PROPIO RIESGO
PADRES SUGERENCIAS: Los visitantes no hablar con un humano, sin embargo convencer que es - la IA sabe muchos temas - Use sólo con SUPERVISIÓN

Yo apuesto a que es IA [http://en.wikipedia.org/wiki/Cleverbot], pero mirar que conversaciones (mi amigo sostiene que va cambiando de gente constantemente):

CITAS TEXTUALES :

Yo : ¿cual es el presidente de españa?
Cleverbot- Su espítafio es: no qué no. El cielo es azul, no lo sabes por que supongo que nunca lo has visto. nunca lo has visto xq eres una makina

Yo : Oye Cleverbot
Cleverbot : ¿Quien es Cleverbot?
Yo :Tu
Cleverbot : Entonces tu quien eres?

¿Que pasa aqui?
Hago este post para demostrarle que se equivoca...

DoEvents!

O dios mio, que gracia!! 
http://www.youtube.com/user/tippexperience?v=4ba1BqJ4S2M&feature=pyv&ad=5903516622&kw=YouTube
Jajajaja

DoEvents!

Suponiendo que tengo 7 Forms, como hago que el septimo se situe debajo de los demas? (sin llamar a los 6 uno a uno y traerlos delante... )
Algo con SetWindowPos() ??

Gracias

[DoEvents¡!]

Para comprobar si una web existe hago esto:

Código (vb) [Seleccionar] Expandir


Option Explicit

Function Check_Web_Exists(ByVal sURL As String) As Boolean
Dim oXHTTP                  As Object
Set oXHTTP = CreateObject("MSXML2.XMLHTTP")
  If Not UCase$(sURL) Like "HTTP:*" Then sURL = "http://" & sURL
  On Error GoTo Error_
  With oXHTTP
      .Open "HEAD", sURL, False
      .Send
      If .Status = 200 Then Check_Web_Exists = True
  End With
  Set oXHTTP = Nothing
  Exit Function
Error_:
End Function

Ejemplo:

Código (vb) [Seleccionar] Expandir

Private Sub Form_Load()
   MsgBox Check_Web_Exists("www.google.es")
   MsgBox Check_Web_Exists("www.eljuaker.net")
End Sub

Devuelve:

Verdadero
Falso

Alguien lo sabe hacer más rapido?¿

DoEvents¡!

[coche con el que estoy corriendo en un videojuego]

Hola, pido ayuda con el siguiente tema:

Utilizando el Cheat Engine 5.4 :

¿¿Cómo podria saber el valor de la memoria del coche con el que estoy corriendo en un videojuego??
Se que si son cifras, lo puedo buscar sin dificultad...

Me podriais explicar un poco y poner un ejemplo?
Muchas gracias de verdad

DoEvents¡!

[kotir]

by kotir:

Fuente

DoEvents¡!

[kotir]

By kotir:

Bueno aki les dejo otro tuto ya no pude modificarlo para aki x q ya no encuentro el psd   pero asi lo dejare bueno nos vemos y disfrutenlo y si pueden ps practikenlo  



Fuente


DoEvents¡!

[DoEvents¡!]

HOla, con esta sencilla funcion mia averiguo los numeros perfectos

Código (delphi) [Seleccionar] Expandir


(* * * * * * * * * * * * * * * * * * * * * * * * * *)
(* Function : IsPerfectNumber                      *)
(* Author   : *PsYkE1*                             *)
(* Mail     : vbpsyke1@mixmail.com                 *)
(* Date     : 24/8/10                              *)
(* Purpose  : Check if number is a perfect number  *)
(* Visit    : http://foro.rthacker.net/            *)
(* * * * * * * * * * * * * * * * * * * * * * * * * *)

function IsPerfectNumber(lNumber:Integer):Boolean;
var
 i : Integer;
 x : Integer;
begin
 I := 0;
 Result := false;
 if lnumber > 0 then
   begin
     for x := 1 to lnumber - 1 do
       begin
         if (lnumber mod x) = 0 then
            i := i + x;
       end;
     if i = lnumber then
      Result := true;
   end;
end;

Ejemplo:

Código (delphi) [Seleccionar] Expandir


procedure TForm1.FormCreate(Sender: TObject);
var
 n:integer;
 s:String;
begin
 n := 6;
 str(n,s);
 if IsPerfectNumber(n) = true then
    edit1.Text:= 'El ' + s + ' es un numero perfecto';
end;

end.

DoEvents¡!

[DoEvents¡!]

Porque no funcionan ninguno de estos codigos?
Aviso que no tengo ni idea de Delphi
Code1:

Código (delphi) [Seleccionar] Expandir

procedure TForm1.FormCreate(Sender: TObject);
var
a:integer;
b:integer;
begin
    a:=4;
    b:=4;
    if a=b then
      edit1.Text:= 'hola';
end.
Code2:

Código (delphi) [Seleccionar] Expandir

function DD(s:string):string;
begin
  result:= s + s + s
end;
/////////////////////////////////////////////////////
procedure TForm1.FormCreate(Sender: TObject);
var
a:string;
begin
    a:='hhh';
    if a = dd('h') then
      edit1.Text:= 'hola';
end.

Gracias!

DoEvents¡!

[DoEvents¡!]

Hola, buscaba musica sinfonica, potente, con coros...
Buff..
Me explico fatal, algo de este estilo:
[youtube=425,350]http://www.youtube.com/watch?v=z2gfDO_8ggQ[/youtube]

Gracias

DoEvents¡!

[DoEvents¡!]

[youtube=425,350]http://www.youtube.com/watch?v=2KxmzgJ-1pM[/youtube]
Jaaaaaaaaaajajajajajajaj 

DoEvents¡!

[Delphi]

Hola, me he pasado a Delphi hace dos dias y he pasado esta funcion que tenia hecha en VB6...  

http://foro.rthacker.net/programacion-visual-basic/%28src%29-%28funcion%29-text_between_words-%28by-*psyke1*%29/

Código (delphi) [Seleccionar] Expandir


(* * * * * * * * * * * * * * * * * * * * * * * * * *)
(* Function : Text_Beetwen_Words                   *)
(* Author   : *PsYkE1*                             *)
(* Mail     : vbpsyke1@mixmail.com                 *)
(* Date     : 24/8/10                              *)
(* Purpose  : Returns text which is beetwen        *)
(*            two words.                           *)
(* Visit    : http://foro.rthacker.net/            *)
(* * * * * * * * * * * * * * * * * * * * * * * * * *)

function InStr(iStart: integer; sText: string; sWord: string): integer;
begin
Result := Pos(sWord,Copy(sText,iStart,Length(sText) - (iStart - 1)));
end;

function Text_Beetwen_Words(sTextToAnalyze:String ; sStartWord:String ; sEndWord:string): String;
var
 iPosition1  : Integer;
 iPosition2  : Integer;
 iStart      : Integer;
begin
    iPosition1 := Instr(1,sTextToAnalyze,sStartWord);
    if iPosition1 > 0 then
     begin
       iStart := (iPosition1 + Length(sStartWord));
       iPosition2 := Instr(iStart,sTextToAnalyze,sEndWord);
     end
    else
     exit;
    if iPosition2 > 0 then
     Result := Copy(sTextToAnalyze,iStart,iPosition2 -1);
end;

Un ejemplo:

Código (delphi) [Seleccionar] Expandir


procedure TForm1.FormCreate(Sender: TObject);
   begin
     (* añade un textbox *)
   edit1.Text:= text_beetwen_words('Hoy estoy muy aburrido','Hoy ',' aburrido');
   end;

end.

Devuelve esto:

estoy muy

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

[Salvador Dalí]

Os dejo unas obras de mi pintor favorito:
Salvador Dalí






DoEvents¡!

[USB]

Hola, según esto:
http://www.genbeta.com/sistemas-operativos/adios-a-autoruninf-en-windows-7

Ya no tienen nada que hacer los virus que se propagan por USB?¿ 

DoEvents¡!

[PD]

Cada vez que entro en el IRC no tengo voz, aviso a un moderador o a un admin, consigo voz, pero me conecto por la tarde y ya no tengo...
Que es lo que pasa?¿

PD: Obviamente me identifico, y no me da ningun error...

Gracias!

DoEvents¡!

[Right$()]

Quizas sea muy simple, pero en fin:

Imaginemos que tengo esto:

Código (vb) [Seleccionar] Expandir


Dim a As Integer
Dim b as Integer

a = 2345
b = CInt(Right$(CStr(a),2))

msgbox a
msgbox b

¿Como obtengo el mismo resultado, peeeeeero sin utilizar Right$()?

Gracias!

DoEvents¡!