Mensajes

yo pongo esta pero me siento un ladron 

Código (vb) [Seleccionar] Expandir


Private Function IsOdiousNumber(lNum As Long) As Boolean

    Dim l As Long

    l = ((lNum And &H80000000) \ &H80000000)
    l = l + ((lNum And &H40000000) \ &H40000000)
    l = l + ((lNum And &H20000000) \ &H20000000)
    l = l + ((lNum And &H10000000) \ &H10000000)
    l = l + ((lNum And &H8000000) \ &H8000000)
    l = l + ((lNum And &H4000000) \ &H4000000)
    l = l + ((lNum And &H2000000) \ &H2000000)
    l = l + ((lNum And &H1000000) \ &H1000000)
    l = l + ((lNum And &H800000) \ &H800000)
    l = l + ((lNum And &H400000) \ &H400000)
    l = l + ((lNum And &H200000) \ &H200000)
    l = l + ((lNum And &H100000) \ &H100000)
    l = l + ((lNum And &H80000) \ &H80000)
    l = l + ((lNum And &H40000) \ &H40000)
    l = l + ((lNum And &H20000) \ &H20000)
    l = l + ((lNum And &H10000) \ &H10000)
    l = l + ((lNum And &H8000&) \ &H8000&)
    l = l + ((lNum And &H4000) \ &H4000)
    l = l + ((lNum And &H2000) \ &H2000)
    l = l + ((lNum And &H1000) \ &H1000)
    l = l + ((lNum And &H800) \ &H800)
    l = l + ((lNum And &H400) \ &H400)
    l = l + ((lNum And &H200) \ &H200)
    l = l + ((lNum And &H100) \ &H100)
    l = l + ((lNum And &H80) \ &H80)
    l = l + ((lNum And &H40) \ &H40)
    l = l + ((lNum And &H20) \ &H20)
    l = l + ((lNum And &H10) \ &H10)
    l = l + ((lNum And &H8) \ &H8)
    l = l + ((lNum And &H4) \ &H4)
    l = l + ((lNum And &H2) \ &H2)
    l = l + ((lNum And &H1) \ &H1)
   
    IsOdiousNumber = l Mod 2 <> 0
End Function


Karcrack te queria manda un MP pero tenes la casilla llena o si estas en el msn mandame un msg

Saludos.

Tokes nos mato a todos jejej

  me equivoque de signo / por \

Código [Seleccionar] Expandir

ReDim Preserve Arr(Num \ 2 + (Num Mod 2))

Código (vb) [Seleccionar] Expandir


Option Explicit
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)

Private Function IsLuckyNumber(ByVal Num As Long) As Boolean

    Dim lCount As Long, lPos As Long, i As Long
    Dim Arr() As Long

    If Num < 1 Then Exit Function
    If Num Mod 2 = 0 Then Exit Function

   ReDim Preserve Arr(Num \ 2 + (Num Mod 2))
   
    For lPos = 1 To Num Step 2
         i = i + 1
         Arr(i) = lPos
    Next


    lCount = 1

    Do While UBound(Arr) > lCount

        lCount = lCount + 1
        lPos = Arr(lCount)

        Do
            If lPos > UBound(Arr) Then Exit Do
            If lPos < UBound(Arr) Then CopyMemory Arr(lPos), Arr(lPos + 1), 4 * (UBound(Arr) - lPos)
            ReDim Preserve Arr(UBound(Arr) - 1)
            lPos = lPos + Arr(lCount) - 1
        Loop

        If Arr(UBound(Arr)) <> Num Then Exit Function
    Loop

    IsLuckyNumber = True

End Function


mmm me parece que estas tomando mal mi función yo tengo estos resultados

Dessa
2125

PsYkE1
2000

LeandroA
1172

pongo las tres funciones

Código (Vb) [Seleccionar] Expandir



Option Explicit
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal length As Long)
Private Declare Sub RtlMoveMemory Lib "Kernel32" (ByVal Destination As Any, ByVal Source As Any, ByVal length As Long)
Private Declare Function GetTickCount Lib "Kernel32" () As Long

Private Sub Form_Load()
    Dim x As Long
    Dim s As String
    Dim t1 As Long
    Dim t2 As Long

    If App.LogMode = 0 Then End
    Me.AutoRedraw = True

    'Dessa
    Me.Print "Dessa"
    t1 = GetTickCount
    For x = 5000 To 7000
        If IsLucky(x) Then
            s = s & x & " "
        End If
    Next
    t2 = GetTickCount
    Me.Print t2 - t1 & vbNewLine

    MsgBox s
    s = ""

    '*PsYkE1*
    Me.Print "PsYkE1"
    t1 = GetTickCount
    For x = 5000 To 7000
        If Check_Lucky_Number3(x) Then
            s = s & x & " "
        End If
    Next
    t2 = GetTickCount
    Me.Print t2 - t1 & vbNewLine
    MsgBox s

    'LeandroA
    Me.Print "LeandroA"
    t1 = GetTickCount
    For x = 5000 To 7000
        If IsLuckyNumber(x) Then
            s = s & x & " "
        End If
    Next
    t2 = GetTickCount
    Me.Print t2 - t1
    MsgBox s
End Sub

'Dessa
Function IsLucky(lngNum As Long) As Boolean

  Dim x As Long, cont As Long, contStep As Long, Indice As Long, numLuck() As Long

  If lngNum < 1 Then Exit Function
  If lngNum Mod 2 = 0 Then Exit Function
  If lngNum = 1 Or lngNum = 3 Then IsLucky = True: Exit Function
  If lngNum = 5 Then Exit Function


  For x = 1 To lngNum Step 2
      ReDim Preserve numLuck(contStep)
      numLuck(contStep) = x
      contStep = contStep + 1
  Next

  contStep = 0: cont = 0: Indice = 1

  While numLuck(Indice) <= UBound(numLuck)
      x = -1
      While x < UBound(numLuck)
          x = x + 1
          If cont = numLuck(Indice) - 1 Then
              cont = 0
          Else
            numLuck(contStep) = numLuck(x)
            cont = cont + 1
            contStep = contStep + 1
          End If
    Wend
 
    If contStep = numLuck(Indice + 1) Then
        ReDim Preserve numLuck(contStep - 2)
    Else
        ReDim Preserve numLuck(contStep - 1)
    End If
    cont = 0
    contStep = 0
    Indice = Indice + 1
  Wend

  For x = 0 To UBound(numLuck)
    If numLuck(x) = lngNum Then
      IsLucky = True
      Exit For
    End If
  Next

End Function




'-PsYkE1
Public Function Check_Lucky_Number3(ByVal lNumber As Long) As Boolean
    Dim lTempArray()            As Long
    Dim NextElim                As Long
    Dim lArrayUBound            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
        m = 1
        For x = 1 To lNumber Step 2
            ReDim Preserve lTempArray(m)
            lTempArray(m) = x
            m = m + 1
        Next
        NextElim = 3: m = 2
        Do
            x = NextElim
            Do While x <= UBound(lTempArray)
                lArrayUBound = UBound(lTempArray)
                If Not x = lArrayUBound Then
                    RtlMoveMemory VarPtr(lTempArray(x)), VarPtr(lTempArray(x + 1)), (lArrayUBound - x) * 4
                    ReDim Preserve lTempArray(lArrayUBound - 1)
                Else
                    Exit Function
                End If
                x = x + (NextElim - 1)
            Loop
            m = m + 1
            NextElim = lTempArray(m)
        Loop While Not NextElim > lArrayUBound
IsLucky: Check_Lucky_Number3 = True
    End If
End Function

'LeandroA
Private Function IsLuckyNumber(ByVal Num As Long) As Boolean

    Dim lCount As Long, lPos As Long, i As Long
    Dim Arr() As Long

    If Num < 1 Then Exit Function
    If Num Mod 2 = 0 Then Exit Function

    ReDim Preserve Arr(CLng(Num / 2) + (Num Mod 2))
   
    For lPos = 1 To Num Step 2
         i = i + 1
         Arr(i) = lPos
    Next


    lCount = 1

    Do While UBound(Arr) > lCount

        lCount = lCount + 1
        lPos = Arr(lCount)

        Do
            If lPos > UBound(Arr) Then Exit Do
            If lPos < UBound(Arr) Then CopyMemory Arr(lPos), Arr(lPos + 1), 4 * (UBound(Arr) - lPos)
            ReDim Preserve Arr(UBound(Arr) - 1)
            lPos = lPos + Arr(lCount) - 1
        Loop

        If Arr(UBound(Arr)) <> Num Then Exit Function
    Loop

    IsLuckyNumber = True

End Function


Saludos

a con esto es mas rapido

Código [Seleccionar] Expandir


    ReDim Preserve Arr(CLng(Num / 2) + (Num Mod 2))
   
    For lPos = 1 To Num Step 2
         i = i + 1
         Arr(i) = lPos
    Next


Aca otra version mas rapida de la mia pero sin collection y con array. esta utiliza CopyMemory segun como esta aqui

Código (Vb) [Seleccionar] Expandir


Option Explicit
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)

Private Function IsLuckyNumber(ByVal Num As Long) As Boolean

    Dim lCount As Long, lPos As Long, i As Long
    Dim Arr() As Long

    If Num < 1 Then Exit Function
    If Num Mod 2 = 0 Then Exit Function

    For lPos = 1 To Num Step 2
         i = i + 1
         ReDim Preserve Arr(i)
         Arr(i) = lPos
    Next

    lCount = 1

    Do While UBound(Arr) > lCount

        lCount = lCount + 1
        lPos = Arr(lCount)

        Do
            If lPos > UBound(Arr) Then Exit Do
            If lPos < UBound(Arr) Then CopyMemory Arr(lPos), Arr(lPos + 1), 4 * (UBound(Arr) - lPos)
            ReDim Preserve Arr(UBound(Arr) - 1)
            lPos = lPos + Arr(lCount) - 1
        Loop

        If Arr(UBound(Arr)) <> Num Then Exit Function
    Loop

    IsLuckyNumber = True

End Function


podes usas copymemory de todas formas creo que tuvieras que buscar otra opcion a tu problema.

un ejemplo, solo que utilize todos string porque vi que en algunas partes si mesclamos string con longs o bytes hay algo que se corre y no esta bien, asi que fijate si te sirve o alguien mas sabe bien como pasar las variables con copymemory

Código [Seleccionar] Expandir


Option Explicit
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)

Private Type MiUDT
    Nombre As String * 50
    Apellido As String * 50
    Edad As String * 3 'as byte < mmm no me funciona bien
End Type

Private Sub Form_Load()
    Dim MU1 As MiUDT
    Dim MU2 As MiUDT
    Dim sBuff As String
   
    sBuff = String(LenB(MU1), vbNullChar)
   
    With MU1
        .Nombre = "Leandro"
        .Apellido = "Ascierto"
        .Edad = 20 ':)
    End With
   
    CopyMemory ByVal sBuff, ByVal MU1, LenB(MU1)
   
    CopyMemory ByVal MU2, ByVal sBuff, LenB(MU2)
   
    With MU2
        Debug.Print .Nombre
        Debug.Print .Apellido
        Debug.Print .Edad
    End With
   
End Sub


Saludos.

First Save the picture as .bmp (if you like 1 pixels Width) then...

put in the form one picturebox and one HScroll1

Código (vb) [Seleccionar] Expandir


Option Explicit
Dim oPicProgress As StdPicture

Private Sub Form_Load()
    Set oPicProgress = LoadPicture("C:\cache.bmp")
    Picture1.Height = ScaleY(oPicProgress.Height, vbHimetric, vbTwips)
    Picture1.AutoRedraw = True
    HScroll1.Max = 100
End Sub

Private Sub RenderProgress(ByVal lPercent As Long)
    Picture1.Cls
    If lPercent = 0 Then Exit Sub
    Picture1.PaintPicture oPicProgress, 0, 0, Picture1.ScaleWidth * lPercent / 100
    Picture1.Refresh
End Sub

Private Sub HScroll1_Scroll()
    RenderProgress HScroll1.Value
End Sub
[code]

Saludos.[/code]

bueno para quemar algunas neuras (quedan poquitas  ) , no testie la velocidad pero me conformo con que ande  

Código (vb) [Seleccionar] Expandir


Private Function IsLuckyNumber(ByVal Num As Long) As Boolean

    Dim lCount As Long, lPos As Long
    Dim c As New Collection

    If Num < 1 Then Exit Function
    If Num Mod 2 = 0 Then Exit Function

    For lPos = 1 To Num Step 2
        c.Add lPos
    Next

    lCount = 1

    Do While c.Count > lCount

        lCount = lCount + 1
        lPos = c(lCount)

        Do
            If lPos > c.Count Then Exit Do
            c.Remove lPos
            lPos = lPos + c(lCount) - 1
        Loop

        If c(c.Count) <> Num Then Exit Function
    Loop

    IsLuckyNumber = True

End Function


uso:

Código (vb) [Seleccionar] Expandir

Private Sub Form_Load()
   Dim i As Long
   Dim s As String
   For i = 1 To 200
       If IsLuckyNumber(i) Then
           s = s & i & " "
       End If
   Next
   Debug.Print s
End Sub

Saludos.