Foro de elhacker.net

Programación => Programación Visual Basic => Mensaje iniciado por: x64core en 4 Enero 2012, 23:06 pm



Título: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: x64core en 4 Enero 2012, 23:06 pm
Buenas a todos gente :)
vengo a proponer un reto, espero que participemos todos :)

RETO: Funcion Extraer Numeros de Cadenas!
Ejemplo:
Input: ewiuc3dskhd8nkd62ndsnk9
Ouput: 38629

Teneis hasta 08/01/2012 ese dia se hara el Testing de nuestras funciones , gana la funcion mas optimizada, la mas veloz de todas!
como testear la velocidad de nuestras funciones?
Con la clase Ctiming: (http://www.xbeat.net/vbspeed/download/CTiming.zip)
NO vale asm inline, ni ninguna magia negra ni blanca :xD,a puro code vb, funct vb, apis, clases

Vamos Participemos todos! ;D



Gente Agrego la Cadena para el TEST por favor tomar en cuenta aunque creo que todas nuestras funciones pasa la prueba ^^


"sdh!w2 28 :-)  9ndk#1@b______dy0--hveybd@  # qism083  s'kl...: su2b7h ++bjsnbvxj77ygv1hiiiioms90nms sjbah b#!1!  --R-E-D--0+-w++ONE***WWW."

RETURN:
"228910083277719010"



Prototipo:

Function MYFUNCTION ( STR as String ) as String



Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: BlackZeroX en 4 Enero 2012, 23:53 pm
Código
  1.  
  2. Private Sub Form_Load()
  3. Dim szCadena As String
  4. Dim szBuffer As String
  5.  
  6.    szBuffer = Space(20)
  7.    szCadena = "ewiuc3dskhd8nkd62ndsnk9"
  8.  
  9.    mMemoryEx.initialize
  10.    MsgBox getNumbers(szCadena, szBuffer)
  11.    MsgBox szBuffer
  12.  
  13. End Sub
  14.  
  15. Private Function getNumbers(ByRef szIn As String, ByRef szBuffer As String)
  16. Dim lnBuff  As Long
  17. Dim iRet    As Long
  18. Dim lpIn    As Long
  19. Dim lpBuff  As Long
  20. Dim word    As Integer
  21.  
  22.    lnBuff = Len(szBuffer)
  23.  
  24.    If (Len(szIn) = 0) Then
  25.        getNumbers = iRet
  26.        Exit Function
  27.    End If
  28.  
  29.    lpIn = StrPtr(szIn)
  30.    lpBuff = StrPtr(szBuffer)
  31.  
  32.    Do
  33.        If (lnBuff = 0) Then Exit Do
  34.        word = mMemoryEx.getWord(lpIn)
  35.  
  36.        If (word >= 48 And 57 >= word) Then
  37.            iRet = (iRet + 1)
  38.            'Mid$(szBuffer, iRet, 1) = Chr(word)
  39.            mMemoryEx.putWord lpBuff, word
  40.            lnBuff = (lnBuff - 1)
  41.            lpBuff = (lpBuff + 2)
  42.        End If
  43.  
  44.        lpIn = (lpIn + 2)
  45.  
  46.    Loop While (word > 0)
  47.  
  48.    getNumbers = iRet
  49.  
  50. End Function
  51.  
  52.  

mMemoryEx.bas

Código:

Option Explicit

Public Const PAGE_EXECUTE_READWRITE As Long = &H40
Public Const PAGE_EXECUTE_WRITECOPY As Long = &H80
Public Const PAGE_EXECUTE_READ As Long = &H20
Public Const PAGE_EXECUTE As Long = &H10
Public Const PAGE_READONLY As Long = 2
Public Const PAGE_WRITECOPY As Long = &H8
Public Const PAGE_NOACCESS As Long = 1
Public Const PAGE_READWRITE As Long = &H4
 
Declare Function VarPtrArr Lib "msvbvm60.dll" Alias "VarPtr" (ByRef Ptr() As Any) As Long
Declare Function IsBadWritePtr Lib "kernel32" (ByVal lp As Long, ByVal ucb As Long) As Long
Declare Function IsBadReadPtr Lib "kernel32" (ByVal lp As Long, ByVal ucb As Long) As Long
Declare Function VirtualProtect Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flNewProtect As Long, ByVal lpflOldProtect As Long) As Long

Private bvHack(0)               As Byte
Private lHackDelta              As Long
Private bInitialized            As Boolean
 
Public Function initialize() As Boolean ' By KarCrack
    On Error GoTo Error_Handle
 
    bvHack(-1) = bvHack(-1) 'Error check
    lHackDelta = VarPtr(bvHack(0))
 
    initialize = True
    bInitialized = initialize
    Exit Function
Error_Handle:
    If Err.Number = 9 Then Debug.Print "Remember to tick 'Remove array boundary check' and compile before using"
'    End
End Function
 
Public Function getByte(ByVal lptr As Long) As Byte ' By KarCrack
    If bInitialized Then getByte = bvHack(lptr - lHackDelta)
End Function
 
Public Function getWord(ByVal lptr As Long) As Integer ' By KarCrack
    If bInitialized Then getWord = makeWord(getByte(lptr + &H0), getByte(lptr + &H1))
End Function
 
Public Function getDWord(ByVal lptr As Long) As Long ' By KarCrack
    If bInitialized Then getDWord = makeDWord(getWord(lptr + &H0), getWord(lptr + &H2))
End Function
 
Public Sub putByte(ByVal lptr As Long, ByVal bByte As Byte) ' By KarCrack
    If bInitialized Then bvHack(lptr - lHackDelta) = bByte
End Sub
 
Public Sub putWord(ByVal lptr As Long, ByVal iWord As Integer) ' By KarCrack
    If bInitialized Then Call putByte(lptr + &H0, iWord And &HFF): Call putByte(lptr + &H1, (iWord And &HFF00&) / &H100)
End Sub
 
Public Sub putDWord(ByVal lptr As Long, ByVal lDWord As Long) ' By KarCrack
    If bInitialized Then Call putWord(lptr + &H0, IIf(lDWord And &H8000&, lDWord Or &HFFFF0000, lDWord And &HFFFF&)): Call putWord(lptr + &H2, (lDWord And &HFFFF0000) / &H10000)
End Sub
 
Public Function makeDWord(ByVal LoWord As Integer, ByVal HiWord As Integer) As Long '[http://www.xbeat.net/vbspeed/c_MakeDWord.htm#MakeDWord05]
    makeDWord = (HiWord * &H10000) Or (LoWord And &HFFFF&)
End Function

'   //  Funciones agregadas...

Function makeWord(ByVal lByte As Byte, ByVal hByte As Byte) As Integer ' By BlackZeroX
    makeWord = (((hByte And &H7F) * &H100&) Or lByte)
    If hByte And &H80 Then makeWord = makeWord Or &H8000
End Function

'/////////////////////
Public Function allocMem(ByVal lSize As Long) As Long
'   //  By BlackZeroX (Thanks to Karcrack).
'   //  Retorna la Dirrecion de un SafeArray.
Dim pBuff()     As Byte
    If (lSize <= &H0) Then Exit Function
    ReDim pBuff(0 To (lSize - 1))
    allocMem = getDWord(VarPtrArr(pBuff))
    putDWord VarPtrArr(pBuff), 0
End Function
 
Public Function reallocMem(ByVal lptr As Long, ByVal lSize As Long) As Long
'   //  By BlackZeroX (Thanks to Karcrack).
'   //  Retorna la Dirrecion de un SafeArray que se retorno en allocMem()/reallocMem().
Dim pBuff()     As Byte
    putDWord VarPtrArr(pBuff), lptr
    If Not (lSize = &H0) Then
        ReDim Preserve pBuff(0 To (lSize - 1))
    Else
        Erase pBuff
    End If
    reallocMem = getDWord(VarPtrArr(pBuff))
    putDWord VarPtrArr(pBuff), 0
End Function
 
Public Function getMemData(ByVal lptr As Long) As Long
'   //  By BlackZeroX (Thanks to Karcrack).
'   //  lPtr debe ser el valor (Address) que retorno en allocMem()/reallocMem().
'   //  Esta funcion retorna la Dirrecion de memoria EDITABLE de lPtr (Dirrecion de un SafeArray).
'   //  Referencias.
'   //  http://msdn.microsoft.com/en-us/library/aa908603.aspx
    If (lptr = &H0) Then Exit Function
    getMemData = getDWord(lptr + &HC)    '   //  obtenemos pvData
End Function
 
Public Sub releaseMem(ByVal lptr As Long)
'   //  By BlackZeroX (Thanks to Karcrack).
'   //  lPtr debe ser la Dirrecion que retorno en allocMem()/reallocMem().
Dim pBuff()     As Byte
    putDWord VarPtrArr(pBuff), lptr
End Sub
 
Public Sub releaseMemStr(ByVal lptr As Long)
'   //  By BlackZeroX (Thanks to Karcrack).
'   //  lPtr debe ser la Dirrecion que retorno en cloneString().
Dim sStr        As String
    putDWord VarPtr(sStr), lptr
End Sub
 
Public Sub swapVarPtr(ByVal lpVar1 As Long, ByVal lpVar2 As Long)
'   //  By BlackZeroX (Thanks to Karcrack).
Dim lAux    As Long
    lAux = getDWord(lpVar1)
    Call putDWord(lpVar1, getDWord(lpVar2))
    Call putDWord(lpVar2, lAux)
End Sub
 
Public Function cloneString(ByVal lpStrDst As Long, ByVal sStrSrc As String) As Long
'   //  By BlackZeroX (Thanks to Karcrack).
'   //  lPtr -> Puntero a una variable destino (Preferiblemente String).
'   //  sStr -> Cadena Clonada ( gracias a Byval ).
Dim lpStrSrc        As Long
    If Not (lpStrDst = &H0) And (mMemoryEx.initialize = True) Then
        Call mMemoryEx.swapVarPtr(lpStrDst, VarPtr(sStrSrc))
        Call mMemoryEx.swapVarPtr(VarPtr(cloneString), VarPtr(sStrSrc))
    End If
End Function
 
Public Function copyMemory(ByVal lpDst As Long, ByVal lpSrc As Long, ByVal lLn As Long) As Long
'   //  By BlackZeroX (Thanks to Karcrack).
Dim i       As Long
    If (lpSrc = &H0) Or (lpDst = &H0) Or (lLn = &H0) Then Exit Function
  
    i = (lLn Mod 4)
    If ((i And &H2) = &H2) Then
        Call putWord(lpDst, getWord(lpSrc))
        lpDst = (lpDst + 2)
        lpSrc = (lpSrc + 2)
        copyMemory = (copyMemory + 2)
        lLn = (lLn - 2)
    End If
    If ((i And &H1) = &H1) Then
        Call putByte(lpDst, getByte(lpSrc))
        lpDst = (lpDst + 1)
        lpSrc = (lpSrc + 1)
        copyMemory = (copyMemory + 1)
        lLn = (lLn - 1)
    End If
    For i = 0 To (lLn - 1) Step 4
        Call putDWord(lpDst + i, getDWord(lpSrc + i))
    Next
    copyMemory = (copyMemory + lLn)
  
End Function


Dulces Lunas!¡.


Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: BlackZeroX en 5 Enero 2012, 00:04 am

Una reducción de mMemoryEx...

Código
  1.  
  2. Private Function getNumbers2(ByRef sIn As String, ByRef sOut As String) As Long
  3. Dim thisWord(0) As Integer  '   //  Un caracter = 2 bytes = integer
  4. Dim dwOffSetGet As Long     '   //  Offset Get caracter...
  5. Dim dwOffSetSet As Long     '   //  Offset Set caracter...
  6. Dim wWord       As Integer  '   //  Letra en asc...
  7. Dim dwRet       As Integer  '   //  Cantidad de digitos encontrados...
  8. Dim dwLenI      As Long     '   //  Longitud en bytes de sIn...
  9. Dim dwLenB      As Long     '   //  Longitud en bytes de sOut...
  10. Dim dwOffset    As Long     '   //  Offset del Buffer...
  11.  
  12.    dwOffSetGet = (StrPtr(sIn) - VarPtr(thisWord(0))) \ 2
  13.    dwLenB = LenB(sOut)
  14.  
  15.    If (dwLenB) Then
  16.        dwOffSetSet = (StrPtr(sOut) - VarPtr(thisWord(0))) \ 2
  17.    End If
  18.    dwLenI = LenB(sIn)
  19.  
  20.    If (dwLenI) Then
  21.        Do
  22.            If (dwLenI And &H80000000) Then Exit Do
  23.  
  24.            wWord = thisWord(dwOffSetGet)
  25.  
  26.            If (wWord >= &H30) Then
  27.                If (wWord <= &H39) Then
  28.                    dwRet = (dwRet + 1)
  29.                    If (dwLenB) Then
  30.                        thisWord(dwOffSetSet) = wWord
  31.                        dwOffSetSet = (dwOffSetSet + 1)
  32.                        dwLenB = (dwLenB - 2)
  33.                    End If
  34.                End If
  35.            End If
  36.  
  37.            dwOffSetGet = (dwOffSetGet + 1)
  38.            dwLenI = (dwLenI - 2)
  39.  
  40.        Loop While (wWord > 0)
  41.    End If
  42.  
  43.    thisWord(dwOffSetSet) = &H0&
  44.    getNumbers2 = dwRet
  45.  
  46. End Function
  47.  
  48.  

o tambien asi:

Código
  1.  
  2. Option Explicit
  3.  
  4. Private Sub Form_Load()
  5. Dim szCadena As String
  6. Dim szBuffer As String
  7. Dim lnBuffer As Long
  8.  
  9.    szCadena = "sdh!w2 28 :-)  9ndk#1@b______dy0--hveybd@  # qism083  s'kl...: su2b7h ++bjsnbvxj77ygv1hiiiioms90nms sjbah b#!1!  --R-E-D--0+-w++ONE***WWW."
  10.    lnBuffer = getNumbers(szCadena, vbNullString)
  11.    szBuffer = Space(lnBuffer)
  12.    MsgBox "Se Obtubieron " & getNumbers(szCadena, szBuffer) & " de " & lnBuffer & vbCrLf & szBuffer
  13. End Sub
  14.  
  15. Private Function getNumbers(ByRef szIn As String, ByRef szBuffer As String) As Long
  16. Dim lnBuff      As Long
  17. Dim lnIn        As Long
  18. Dim iRet        As Long
  19. Dim lPosIn      As Long
  20. Dim lPosBuff    As Long
  21. Dim word        As Integer
  22.  
  23.    lnBuff = LenB(szBuffer)
  24.    lnIn = LenB(szIn)
  25.  
  26.    If (Len(szIn) = 0) Then
  27.        getNumbers = iRet
  28.        Exit Function
  29.    End If
  30.  
  31.    lPosIn = &H1
  32.    lPosBuff = &H1
  33.  
  34.    Do
  35.        If (lnIn <= lPosIn) Then Exit Do
  36.        word = Asc(MidB(szIn, lPosIn, 2))
  37.  
  38.        If (word >= 48 And 57 >= word) Then
  39.            iRet = (iRet + 1)
  40.            If (lnBuff) Then
  41.                MidB(szBuffer, lPosBuff, 2) = Chr(word)
  42.                lnBuff = (lnBuff - 2)
  43.            End If
  44.            lPosBuff = (lPosBuff + 2)
  45.        End If
  46.  
  47.        lPosIn = (lPosIn + 2)
  48.  
  49.    Loop While (word > 0)
  50.  
  51.    getNumbers = iRet
  52.  
  53. End Function
  54.  
  55.  

Dulces Lunas!¡.


Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: W0lFy en 5 Enero 2012, 09:51 am
es un sistema de cifrado? me ha llamado la atencion por que yo ando haciendo tambien algoritmos de cifrado. Un saludo!


Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: BlackZeroX en 5 Enero 2012, 10:54 am
es un sistema de cifrado? me ha llamado la atencion por que yo ando haciendo tambien algoritmos de cifrado. Un saludo!

¿SABES LEER?

Dulces Lunas!¡.


Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: Karcrack en 5 Enero 2012, 11:42 am
No debería devolver un número?
Deberías poner la declaración de la función, para que BlackZeroX no empiece a usar buffers declarados fuera de esta :P


Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: 79137913 en 5 Enero 2012, 13:02 pm
HOLA!!!

Estoy trabajando mucho, pero nunca dije que no a un reto...

EDITE LA FUNCION


Código
  1. Private Function ExtractNums7913(expression As String) As String
  2.    Dim a() As Byte
  3.    Dim b() As Byte
  4.    Dim ct As Long
  5.        a = expression
  6.        b = a
  7.        For x = 0 To UBound(a) Step 2
  8.            If a(x) < 58 Then
  9.                If a(x) > 47 Then
  10.                    b(ct + ct) = a(x)
  11.                    ct = ct + 1
  12.                End If
  13.            End If
  14.        Next
  15.        ReDim Preserve b(ct + ct)
  16.        ExtractNums7913 = b
  17. End Function

P.D: NO COMPARTO EL USO DE CLASES O FUNCIONES EXTERNAS, SI ES UNA FUNCION QUE SE VALGA POR ELLA MISMA.

P.D2: ESTOY USANDO MAGIA NEGRA... (EVIL TYPE CONVERT // BAD TYPE CONVERT) PERO ES VALIDO PARA MI.

P.D3: TENES QUE PONER LA DECLARACION DE LA FUNCION POR EJEMPLO:
Private Function ExtractNums7913(expression As String) As String
POR QUE SINO SE PUEDE JUGAR CON LOS TIPOS.


GRACIAS POR LEER!!!


Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: Elemental Code en 5 Enero 2012, 18:18 pm
RUSTICO MODE ON!


Código
  1. Function RUSTICOnumbers_eCode(ByRef sSTR As String) As String
  2.    Dim i As Integer
  3.    Dim x As String * 1
  4.    For i = 1 To Len(sSTR)
  5.    x = Mid(sSTR, i, 1)
  6.        Select Case x
  7.            Case 0 To 9
  8.                RUSTICOnumbers_eCode = RUSTICOnumbers_eCode & x
  9.        End Select
  10.    Next
  11. End Function


Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: x64core en 5 Enero 2012, 19:52 pm
No debería devolver un número?
Deberías poner la declaración de la función, para que BlackZeroX no empiece a usar buffers declarados fuera de esta :P
La verdad fue error mio al no aclarar que tipo de variable deberia devolver y si lo modifico ya no tendria sentido :P



Aqui esta la mia: ;D

Código
  1. Option Explicit
  2.  
  3.  
  4. Private Declare Sub MOV Lib "ntdll.dll" Alias "#1042" _
  5. (d As Any, s As Any, ByVal l As Long)
  6.  
  7. Private Function GetNums(RetSTR As String) As String
  8. Dim lpStr       As Long
  9. Dim lpret       As Long
  10. Dim ln          As Long
  11. Dim b           As Long
  12. Dim t           As Integer
  13.  
  14.    GetNums = RetSTR
  15.    lpStr = StrPtr(GetNums): lpret = lpStr
  16.    ln = LenB(GetNums)
  17.  
  18.    For lpStr = lpStr To (lpStr + ln) Step &H2
  19.        MOV t, ByVal lpStr, &H2
  20.        If (t >= &H30) Then
  21.            If (t <= &H39) Then
  22.                MOV ByVal lpret + b, t, &H2
  23.                b = b + &H2
  24.            End If
  25.        End If
  26.    Next
  27.  
  28.    MOV ByVal lpret + b, &H0, &H2
  29.    MOV ByVal (lpret - &H4), b, &H4
  30. End Function
  31.  
  32.  
  33.  



EDIT:

P.D: NO COMPARTO EL USO DE CLASES O FUNCIONES EXTERNAS, SI ES UNA FUNCION QUE SE VALGA POR ELLA MISMA.
Si, una funcion deberia valerse por si misma pero es problema de nostros ya que llamadas a apis, funciones y demas recursos cuestan tiempo
de ejecucion como dije, gana el codigo mas optimizado no importando que use apis,clases, etc...




Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: seba123neo en 5 Enero 2012, 22:44 pm
no soy de entrar en estos test, pero aca dejo algo simple con RegEx:

Código
  1. Private Sub Form_Load()
  2.    Dim i As String
  3.    i = "sdh!w2 28 :-)  9ndk#1@b______dy0--hveybd@  # qism083  s'kl...: su2b7h ++bjsnbvxj77ygv1hiiiioms90nms sjbah b#!1!  --R-E-D--0+-w++ONE***WWW."
  4.  
  5.    Dim obj_Expresion As Object
  6.    Set obj_Expresion = CreateObject("VBScript.RegExp")
  7.  
  8.    obj_Expresion.Pattern = "\d+"
  9.    obj_Expresion.IgnoreCase = True
  10.    obj_Expresion.Global = True
  11.  
  12.    Dim ExtractNumbers As Object
  13.    Set ExtractNumbers = obj_Expresion.Execute(i)
  14.  
  15.    Dim ii As Long
  16.    For ii = 0 To ExtractNumbers.Count - 1
  17.        Debug.Print ExtractNumbers(ii)
  18.    Next
  19. End Sub

saludos.


Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: BlackZeroX en 5 Enero 2012, 23:28 pm
No debería devolver un número?
Deberías poner la declaración de la función, para que BlackZeroX no empiece a usar buffers declarados fuera de esta :P

¡TE MALDIGO¡.

@RHL - 该0在
Maldito Tramposo usas la misma String para retornar...


¡Aun asi dejo la actualizada! (Edite mi codigo).

Dulces Lunas!¡.


Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: x64core en 5 Enero 2012, 23:34 pm
 :xD
no es trampa v_v
haber quien le gana a mi MOV :3


Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: Karcrack en 6 Enero 2012, 00:56 am
@RHL: No deberías declarar RtlMoveMemory() por el ordinal... es probable que no funcione en todas las versiones de W$.

Mi código:
Código
  1. Private Static Sub kGetNums(ByRef s As String)
  2.    Dim bv(0)   As Byte
  3.    Dim pbv     As Long
  4.    Dim rps     As Long
  5.    Dim i       As Long
  6.    Dim b       As Byte
  7.    Dim w       As Long
  8.  
  9.    If pbv = 0 Then pbv = VarPtr(bv(0))
  10.  
  11.    rps = StrPtr(s) - pbv
  12.    w = 0
  13.  
  14.    For i = 0 To LenB(s) Step 10
  15.        b = bv(rps + i + 0)
  16.        If b >= &H30 Then
  17.            If b <= &H39 Then
  18.                bv(rps + w) = b
  19.                w = w + 2
  20.            End If
  21.        End If
  22.        b = bv(rps + i + 2)
  23.        If b >= &H30 Then
  24.            If b <= &H39 Then
  25.                bv(rps + w) = b
  26.                w = w + 2
  27.            End If
  28.        End If
  29.        b = bv(rps + i + 4)
  30.        If b >= &H30 Then
  31.            If b <= &H39 Then
  32.                bv(rps + w) = b
  33.                w = w + 2
  34.            End If
  35.        End If
  36.        b = bv(rps + i + 6)
  37.        If b >= &H30 Then
  38.            If b <= &H39 Then
  39.                bv(rps + w) = b
  40.                w = w + 2
  41.            End If
  42.        End If
  43.        b = bv(rps + i + 8)
  44.        If b >= &H30 Then
  45.            If b <= &H39 Then
  46.                bv(rps + w) = b
  47.                w = w + 2
  48.            End If
  49.        End If
  50.    Next i
  51.  
  52.    bv(rps + w) = 0
  53. End Sub
  54.  
Código
  1. dim x as string
  2. x = "1e2e3a4b"
  3. call kGetNums(x)
  4. msgbox x
HAY QUE DESACTIVAR LA COMPROBACIÓN DE TAMAÑO DEL BUFFER!!! Y probar compilado (of course!)!!!
He arriesgado un poco con el unwinding del bucle... pero ya veremos los resultados :laugh: :laugh:

Sería conveniente también que para hacer las pruebas de velocidad además de hacerlo compilado hacerlo sin comprobación de buffers y comprobación de overflow!!

PD: He ganado a "tu" mov :P :P


Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: BlackZeroX en 6 Enero 2012, 01:18 am
Yo hiba a hacer el truquito de "Quitar la comprovacion en limites de las matrices"...  :¬¬ eso me pasa por irme a bañar  :¬¬.

Ahora te odio mas...

Temibles Lunas!¡.


Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: x64core en 6 Enero 2012, 01:21 am
Eso ya es magia negra o blanca v_v
igual ya termino todo me temía lo peor v_v' osea un mov sin apis ni asm inline
ya hay ganador no creo que nadie supere la funcion la funcion de karcrack :P v_V

EDIT:
@Karcrack
Karcrack, te espero en el proximo reto que se valdra absolutamente de todo!



Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: 79137913 en 6 Enero 2012, 02:07 am
HOLA!!!

Como me lo imaginaba Kcrack WON XD.


@KCrack:
Como hago para que una funcion :
Private Function A (b() as byte) as byte ()

Me soporte la entrada de srtings en b() as byte ...


@Raul, no me podes usar la misma variable para devolver y pedir  retLen XD, ... por eso siempre digo que hay que poner la declaracion de la funcion sino se da lugar a confuciones.

GRACIAS POR LEER!!!


Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: BlackZeroX en 6 Enero 2012, 02:24 am
La funcion de Karcrack me crashea mmm aun asi prueba esta funcion... ("Quitar la comprovacion en limites de las matrices)... En TEORIA es mas rapida que la que puso Karcrack...

Código
  1.  
  2. Private Function getNumbers2(ByRef sIn As String, ByRef sOut As String) As Long
  3. Dim thisWord(0) As Integer  '   //  Un caracter = 2 bytes = integer
  4. Dim dwOffSetGet As Long     '   //  Offset Get caracter...
  5. Dim dwOffSetSet As Long     '   //  Offset Set caracter...
  6. Dim wWord       As Integer  '   //  Letra en asc...
  7. Dim dwRet       As Integer  '   //  Cantidad de digitos encontrados...
  8. Dim dwLenI      As Long     '   //  Longitud en bytes de sIn...
  9. Dim dwLenB      As Long     '   //  Longitud en bytes de sOut...
  10. Dim dwOffset    As Long     '   //  Offset del Buffer...
  11.  
  12.    dwOffSetGet = (StrPtr(sIn) - VarPtr(thisWord(0))) \ 2
  13.    dwLenB = LenB(sOut)
  14.  
  15.    If (dwLenB) Then
  16.        dwOffSetSet = (StrPtr(sOut) - VarPtr(thisWord(0))) \ 2
  17.    End If
  18.    dwLenI = LenB(sIn)
  19.  
  20.    If (dwLenI) Then
  21.        Do
  22.            If (dwLenI And &H80000000) Then Exit Do
  23.  
  24.            wWord = thisWord(dwOffSetGet)
  25.  
  26.            If (wWord >= &H30) Then
  27.                If (wWord <= &H39) Then
  28.                    dwRet = (dwRet + 1)
  29.                    If (dwLenB) Then
  30.                        thisWord(dwOffSetSet) = wWord
  31.                        dwOffSetSet = (dwOffSetSet + 1)
  32.                        dwLenB = (dwLenB - 2)
  33.                    End If
  34.                End If
  35.            End If
  36.  
  37.            dwOffSetGet = (dwOffSetGet + 1)
  38.            dwLenI = (dwLenI - 2)
  39.  
  40.        Loop While (wWord > 0)
  41.    End If
  42.  
  43.    thisWord(dwOffSetSet) = &H0&
  44.    getNumbers2 = dwRet
  45.  
  46. End Function
  47.  
  48.  


Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: seba123neo en 6 Enero 2012, 02:25 am
yo probe la funcion de Karcrack y no hay manera de que funcione, me tira subindice fuera del intervalo.

saludos.


Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: BlackZeroX en 6 Enero 2012, 02:27 am
Cuando lo compiles "Quitar la comprovacion en limites de las matrices"... hay en Opciones despues de darle generar exe...

Dulces Lunas!¡.


Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: x64core en 6 Enero 2012, 02:27 am
@79137913
el retlen lo escribi porque yo queria, la longitud de los valores encontrados no venia al reto
osea era cuestion de uno, y en cuanto a devolver y recibir en la misma variable... esta bien modificare el codigo a tu gusto ;)

Funcion GetNums ( STR as string ) as string


Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: 79137913 en 6 Enero 2012, 02:27 am
HOLA!!!

COMPILEN XD! Y TILDEN LAS OPCIONES AVANZADAS DE COMPILACION.

GRACIAS POR LEER!!!


Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: x64core en 6 Enero 2012, 02:29 am
Citar
La funcion de Karcrack crashea mmm aun asi prueba esta funcion...

La funcion de Karcrack SI FUNCIONA, ya hasta comprobe las velocidades de todas las funciones...


@BlackZeroX:
CUal es tu funcion?  :¬¬


Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: BlackZeroX en 6 Enero 2012, 02:30 am
La funcion de Karcrack SI FUNCIONA, ya hasta comprobe las velocidades de todas las funciones...

Compruba la ultima mia!¡... Quien sabe por que me Crasheo el exe entonces xP...

Dulces Lunas!¡.


Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: BlackZeroX en 6 Enero 2012, 02:32 am
@BlackZeroX:
CUal es tu funcion?  :¬¬

http://foro.elhacker.net/programacion_visual_basic/reto_funcion_extraer_numeros_de_cadenas-t349507.0.html;msg1703520#msg1703520

Es una reduccion de la 1ra que puse que usa mMemoryEx es decir esta: http://foro.elhacker.net/programacion_visual_basic/reto_funcion_extraer_numeros_de_cadenas-t349507.0.html;msg1702926#msg1702926


Nota: La podre en el primer Post de este Hilo...
Dulces Lunas!¡.


Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: x64core en 6 Enero 2012, 02:36 am
Bien entonces son dos :P


http://foro.elhacker.net/programacion_visual_basic/reto_funcion_extraer_numeros_de_cadenas-t349507.0.html;msg1703520#msg1703520

http://foro.elhacker.net/programacion_visual_basic/reto_funcion_extraer_numeros_de_cadenas-t349507.0.html;msg1702926#msg1702926

EDIT:

@BlackZeroX:
Retorno long?

Funcion GetNums ( STR as string ) as string




Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: BlackZeroX en 6 Enero 2012, 02:39 am
Bien entonces son dos :P

De hecho son como 4... pero usa la que te dije (esta (http://foro.elhacker.net/programacion_visual_basic/reto_funcion_extraer_numeros_de_cadenas-t349507.0.html;msg1703520#msg1703520))

-> En tu post PRINCIPAL NUNCA mencionas el prototipo, si el prototipo es:

Private Sub getNumbers3(ByRef sIn As String)

Entonces usa esta:

Código
  1.  
  2. Private Sub getNumbers3(ByRef sIn As String)
  3. Dim thisWord(0) As Integer  '   //  Un caracter = 2 bytes = integer
  4. Dim dwOffSetGet As Long     '   //  Offset Get caracter...
  5. Dim dwOffSetSet As Long     '   //  Offset Set caracter...
  6. Dim wWord       As Integer  '   //  Letra en asc...
  7. Dim dwLenI      As Long     '   //  Longitud en bytes de sIn...
  8.  
  9.    dwOffSetGet = ((StrPtr(sIn) - VarPtr(thisWord(0))) \ 2)
  10.    dwOffSetSet = dwOffSetGet
  11.    dwLenI = LenB(sIn)
  12.  
  13.    If (dwLenI) Then
  14.        Do
  15.            If (dwLenI And &H80000000) Then Exit Do
  16.  
  17.            wWord = thisWord(dwOffSetGet)
  18.  
  19.            If (wWord >= &H30) Then
  20.                If (wWord <= &H39) Then
  21.                    thisWord(dwOffSetSet) = wWord
  22.                    dwOffSetSet = (dwOffSetSet + 1)
  23.                End If
  24.            End If
  25.  
  26.            dwOffSetGet = (dwOffSetGet + 1)
  27.            dwLenI = (dwLenI - 2)
  28.  
  29.        Loop While (wWord > 0)
  30.    End If
  31.  
  32.    thisWord(dwOffSetSet) = &H0&
  33.  
  34. End Sub
  35.  
  36.  

Dulces Lunas!¡.


Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: x64core en 6 Enero 2012, 02:49 am
De hecho son como 4... pero usa la que te dije (esta (http://foro.elhacker.net/programacion_visual_basic/reto_funcion_extraer_numeros_de_cadenas-t349507.0.html;msg1703520#msg1703520))

Nota: En tu post PRINCIPAL NUNCA mencionas el prototipo, avisame y te la pongo modificada ¬¬"...

Dulces Lunas!¡.

Si, pido disculpa por eso al fin y al cabo creo que ya hay ganador :xD
pero para que el reto sea lo mas transparente posible y para todos esten conforme con los resultados
igual la funcion de Karcrack devuelve en la misma variable, igual que la mía, igual solo se hace
var = var





Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: BlackZeroX en 6 Enero 2012, 02:50 am
y los tiempos?...

Dulces Lunas!¡...


Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: seba123neo en 6 Enero 2012, 03:01 am
he estado probando los tiempos y la ultima que puso BlackZeroX dura tres veces menos que la de Karcrack.


Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: x64core en 6 Enero 2012, 03:07 am
he estado probando los tiempos y la ultima que puso BlackZeroX dura tres veces menos que la de Karcrack.

Las pruebas en tiempo de ejecucion no?
creo que solo así se podra comparar una que solo se obtiene el resultado en tiempo de ejecucion que otra desde el IDE.. :P
Corroborar :P


Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: seba123neo en 6 Enero 2012, 03:10 am
Las pruebas en tiempo de ejecucion no?
creo que solo así se podra comparar una que solo se obtiene el resultado en tiempo de ejecucion que otra desde el IDE.. :P
Corroborar :P

las probe compilado a las 2 funciones.



Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: BlackZeroX en 6 Enero 2012, 03:17 am
Las pruebas en tiempo de ejecucion no?
creo que solo así se podra comparar una que solo se obtiene el resultado en tiempo de ejecucion que otra desde el IDE.. :P
Corroborar :P

Por si las moscas comprubelas COMPILADAS no desde el IDE, aun asi tanto la de Karcr... y la de un servidor NO FUNCIONAN desde el IDE...

Dulces Lunas!¡.


Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: BlackZeroX en 6 Enero 2012, 03:51 am
...
Esta es la ultima que pongo lo PROMETO!¡.

Esta modificada segun el Prototipo...

Código
  1.  
  2. Public Function getNumbers3(ByRef sIn As String) As String
  3. Dim thisWord(0) As Integer  '   //  Un caracter = 2 bytes = integer
  4. Dim thisRet(0)  As Long     '   //  jejeje...
  5. Dim dwOffSetGet As Long     '   //  Offset Get caracter...
  6. Dim dwOffSetSet As Long     '   //  Offset Set caracter...
  7. Dim wWord       As Integer  '   //  Letra en asc...
  8. Dim dwLenI      As Long     '   //  Longitud en bytes de sIn...
  9. Dim lpAux       As Long     '   //  Auxiliar...
  10. Dim dwRetLen    As Long     '   //  jejeje...
  11.  
  12.    dwOffSetGet = ((StrPtr(sIn) - VarPtr(thisWord(&H0&))) \ &H2&)
  13.    dwOffSetSet = dwOffSetGet
  14.    dwLenI = LenB(sIn)
  15.  
  16.    If (dwLenI) Then
  17.        Do
  18.            If (dwLenI And &H80000000) Then Exit Do
  19.  
  20.            wWord = thisWord(dwOffSetGet)
  21.  
  22.            If (wWord >= &H30) Then
  23.                If (wWord <= &H39) Then
  24.                    dwRetLen = (dwRetLen + &H2&)
  25.                    thisWord(dwOffSetSet) = wWord
  26.                    dwOffSetSet = (dwOffSetSet + &H1&)
  27.                End If
  28.            End If
  29.  
  30.            dwOffSetGet = (dwOffSetGet + &H1&)
  31.            dwLenI = (dwLenI - &H2&)
  32.  
  33.        Loop While (wWord > &H0&)
  34.  
  35.        thisWord(dwOffSetSet) = &H0&
  36.        lpAux = ((VarPtr(sIn) - VarPtr(thisRet(&H0&))) \ &H4&)
  37.        thisRet(((StrPtr(sIn) - VarPtr(thisRet(&H0&))) \ &H4&) - &H1&) = dwRetLen
  38.        thisRet(((VarPtr(getNumbers3) - VarPtr(thisRet(&H0&))) \ &H4&)) = thisRet(lpAux)
  39.        thisRet(lpAux) = &H0&
  40.    End If
  41.  
  42. End Function
  43.  
  44.  

Temibles Lunas!¡.


Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: Karcrack en 6 Enero 2012, 13:44 pm
Voy a arriesgar: BlackZeroX tu código no funcionará siempre :P Y si funciona es de suerte :P

Te arriesgas a que por alguna razón VB6 te meta el array de words en una dirección impar y a partir de ahí todos tus accesos ya no son correctos >:D


Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: BlackZeroX en 6 Enero 2012, 17:27 pm
Voy a arriesgar: BlackZeroX tu código no funcionará siempre :P Y si funciona es de suerte :P

Te arriesgas a que por alguna razón VB6 te meta el array de words en una dirección impar y a partir de ahí todos tus accesos ya no son correctos >:D

Te equivocas y muy feo esta vez... ya que cuando se hace un acceso a memoria de un array se hace siguiento esta forma si no mal me quivoco

AddressBase + Index * sizeof(Tipo)

Donde AddressBase es el Indice 0 del array...

Revisala y dale un debug... que la verdad a mi tambien de dio unos dolores de cabeza debido a que el tipo del array lo cambien de un array tipo byte a uno integer y a uno long es decir de 1 byte a 2 bytes y a 4 bytes...

Código
  1.  
  2. Option Explicit
  3.  
  4. Private Sub Command1_Click()
  5. Dim sStr    As String
  6. Dim i       As Long
  7. Dim lpLast  As Long
  8.  
  9.    Show
  10.  
  11.    For i = 0 To 500
  12.        sStr = " 1234567890"  ' // Nos tiene que devolver esactamente LO MISMO...
  13.        lpLast = StrPtr(sStr)
  14.        Text1.Text = i & vbTab & lpLast & vbTab & getNumbers3(sStr) & vbCrLf & Text1.Text
  15.        DoEvents
  16.        Caption = i
  17.    Next i
  18.  
  19.    sStr = "hola54 mundo5412"
  20.    MsgBox getNumbers3(sStr)
  21.    MsgBox sStr
  22.  
  23.    End     '   //  Fozamos...
  24. End Sub
  25.  
  26.  

Output:

Código:

500 2353284 1234567890
499 2353404 1234567890
498 2353364 1234567890
497 2353324 1234567890
496 2353284 1234567890
495 2353404 1234567890
494 2353364 1234567890
493 2353324 1234567890
492 2353284 1234567890
491 2353404 1234567890
490 2353364 1234567890
489 2353324 1234567890
488 2353284 1234567890
487 2353404 1234567890
486 2353364 1234567890
485 2353324 1234567890
484 2353284 1234567890
483 2353404 1234567890
482 2353364 1234567890
481 2353324 1234567890
480 2353284 1234567890
479 2353404 1234567890
478 2353364 1234567890
477 2353324 1234567890
476 2353284 1234567890
475 2353404 1234567890
474 2353364 1234567890
473 2353324 1234567890
472 2353284 1234567890
471 2353404 1234567890
470 2353364 1234567890
469 2353324 1234567890
468 2353284 1234567890
467 2353404 1234567890
466 2353364 1234567890
465 2353324 1234567890
464 2353284 1234567890
463 2353404 1234567890
462 2353364 1234567890
461 2353324 1234567890
460 2353284 1234567890
459 2353404 1234567890
458 2353364 1234567890
457 2353324 1234567890
456 2353284 1234567890
455 2353404 1234567890
454 2353364 1234567890
453 2353324 1234567890
452 2353284 1234567890
451 2353404 1234567890
450 2353364 1234567890
449 2353324 1234567890
448 2353284 1234567890
447 2353404 1234567890
446 2353364 1234567890
445 2353324 1234567890
444 2353284 1234567890
443 2353404 1234567890
442 2353364 1234567890
441 2353324 1234567890
440 2353284 1234567890
439 2353404 1234567890
438 2353364 1234567890
437 2353324 1234567890
436 2353284 1234567890
435 2353404 1234567890
434 2353364 1234567890
433 2353324 1234567890
432 2353284 1234567890
431 2353404 1234567890
430 2353364 1234567890
429 2353324 1234567890
428 2353284 1234567890
427 2353404 1234567890
426 2353364 1234567890
425 2353324 1234567890
424 2353284 1234567890
423 2353404 1234567890
422 2353364 1234567890
421 2353324 1234567890
420 2353284 1234567890
419 2353404 1234567890
418 2353364 1234567890
417 2353324 1234567890
416 2353284 1234567890
415 2353404 1234567890
414 2353364 1234567890
413 2353324 1234567890
412 2353284 1234567890
411 2353404 1234567890
410 2353364 1234567890
409 2353324 1234567890
408 2353284 1234567890
407 2353404 1234567890
406 2353364 1234567890
405 2353324 1234567890
404 2353284 1234567890
403 2353404 1234567890
402 2353364 1234567890
401 2353324 1234567890
400 2353284 1234567890
399 2353404 1234567890
398 2353364 1234567890
397 2353324 1234567890
396 2353284 1234567890
395 2353404 1234567890
394 2353364 1234567890
393 2353324 1234567890
392 2353284 1234567890
391 2353404 1234567890
390 2353364 1234567890
389 2353324 1234567890
388 2353284 1234567890
387 2353404 1234567890
386 2353364 1234567890
385 2353324 1234567890
384 2353284 1234567890
383 2353404 1234567890
382 2353364 1234567890
381 2353324 1234567890
380 2353284 1234567890
379 2353404 1234567890
378 2353364 1234567890
377 2353324 1234567890
376 2353284 1234567890
375 2353404 1234567890
374 2353364 1234567890
373 2353324 1234567890
372 2353284 1234567890
371 2353404 1234567890
370 2353364 1234567890
369 2353324 1234567890
368 2353284 1234567890
367 2353404 1234567890
366 2353364 1234567890
365 2353324 1234567890
364 2353284 1234567890
363 2353404 1234567890
362 2353364 1234567890
361 2353324 1234567890
360 2353284 1234567890
359 2353404 1234567890
358 2353364 1234567890
357 2353324 1234567890
356 2353284 1234567890
355 2353404 1234567890
354 2353364 1234567890
353 2353324 1234567890
352 2353284 1234567890
351 2353404 1234567890
350 2353364 1234567890
349 2353324 1234567890
348 2353284 1234567890
347 2353404 1234567890
346 2353364 1234567890
345 2353324 1234567890
344 2353284 1234567890
343 2353404 1234567890
342 2353364 1234567890
341 2353324 1234567890
340 2353284 1234567890
339 2353404 1234567890
338 2353364 1234567890
337 2353324 1234567890
336 2353284 1234567890
335 2353404 1234567890
334 2353364 1234567890
333 2353324 1234567890
332 2353284 1234567890
331 2353404 1234567890
330 2353364 1234567890
329 2353324 1234567890
328 2353284 1234567890
327 2353404 1234567890
326 2353364 1234567890
325 2353324 1234567890
324 2353284 1234567890
323 2353404 1234567890
322 2353364 1234567890
321 2353324 1234567890
320 2353284 1234567890
319 2353404 1234567890
318 2353364 1234567890
317 2353324 1234567890
316 2353284 1234567890
315 2353404 1234567890
314 2353364 1234567890
313 2353324 1234567890
312 2353284 1234567890
311 2353404 1234567890
310 2353364 1234567890
309 2353324 1234567890
308 2353284 1234567890
307 2353404 1234567890
306 2353364 1234567890
305 2353324 1234567890
304 2353284 1234567890
303 2353404 1234567890
302 2353364 1234567890
301 2353324 1234567890
300 2353284 1234567890
299 2353404 1234567890
298 2353364 1234567890
297 2353324 1234567890
296 2353284 1234567890
295 2353404 1234567890
294 2353364 1234567890
293 2353324 1234567890
292 2353284 1234567890
291 2353404 1234567890
290 2353364 1234567890
289 2353324 1234567890
288 2353284 1234567890
287 2353404 1234567890
286 2353364 1234567890
285 2353324 1234567890
284 2353284 1234567890
283 2353404 1234567890
282 2353364 1234567890
281 2353324 1234567890
280 2353284 1234567890
279 2353404 1234567890
278 2353364 1234567890
277 2353324 1234567890
276 2353284 1234567890
275 2353404 1234567890
274 2353364 1234567890
273 2353324 1234567890
272 2353284 1234567890
271 2353404 1234567890
270 2353364 1234567890
269 2353324 1234567890
268 2353284 1234567890
267 2353404 1234567890
266 2353364 1234567890
265 2353324 1234567890
264 2353284 1234567890
263 2353404 1234567890
262 2353364 1234567890
261 2353324 1234567890
260 2353284 1234567890
259 2353404 1234567890
258 2353364 1234567890
257 2353324 1234567890
256 2353284 1234567890
255 2353404 1234567890
254 2353364 1234567890
253 2353324 1234567890
252 2353284 1234567890
251 2353404 1234567890
250 2353364 1234567890
249 2353324 1234567890
248 2353284 1234567890
247 2353404 1234567890
246 2353364 1234567890
245 2353324 1234567890
244 2353284 1234567890
243 2353404 1234567890
242 2353364 1234567890
241 2353324 1234567890
240 2353284 1234567890
239 2353404 1234567890
238 2353364 1234567890
237 2353324 1234567890
236 2353284 1234567890
235 2353404 1234567890
234 2353364 1234567890
233 2353324 1234567890
232 2353284 1234567890
231 2353404 1234567890
230 2353364 1234567890
229 2353324 1234567890
228 2353284 1234567890
227 2353404 1234567890
226 2353364 1234567890
225 2353324 1234567890
224 2353284 1234567890
223 2353404 1234567890
222 2353364 1234567890
221 2353324 1234567890
220 2353284 1234567890
219 2353404 1234567890
218 2353364 1234567890
217 2353324 1234567890
216 2353284 1234567890
215 2353404 1234567890
214 2353364 1234567890
213 2353324 1234567890
212 2353284 1234567890
211 2353404 1234567890
210 2353364 1234567890
209 2353324 1234567890
208 2353284 1234567890
207 2353404 1234567890
206 2353364 1234567890
205 2353324 1234567890
204 2353284 1234567890
203 2353404 1234567890
202 2353364 1234567890
201 2353324 1234567890
200 2353284 1234567890
199 2353404 1234567890
198 2353364 1234567890
197 2353324 1234567890
196 2353284 1234567890
195 2353404 1234567890
194 2353364 1234567890
193 2353324 1234567890
192 2353284 1234567890
191 2353404 1234567890
190 2353364 1234567890
189 2353324 1234567890
188 2353284 1234567890
187 2353404 1234567890
186 2353364 1234567890
185 2353324 1234567890
184 2353284 1234567890
183 2353404 1234567890
182 2353364 1234567890
181 2353324 1234567890
180 2353284 1234567890
179 2353404 1234567890
178 2353364 1234567890
177 2353324 1234567890
176 2353284 1234567890
175 2353404 1234567890
174 2353364 1234567890
173 2353324 1234567890
172 2353284 1234567890
171 2353404 1234567890
170 2353364 1234567890
169 2353324 1234567890
168 2353284 1234567890
167 2353404 1234567890
166 2353364 1234567890
165 2353324 1234567890
164 2353284 1234567890
163 2353404 1234567890
162 2353364 1234567890
161 2353324 1234567890
160 2353284 1234567890
159 2353404 1234567890
158 2353364 1234567890
157 2353324 1234567890
156 2353284 1234567890
155 2353404 1234567890
154 2353364 1234567890
153 2353324 1234567890
152 2353284 1234567890
151 2353404 1234567890
150 2353364 1234567890
149 2353324 1234567890
148 2353284 1234567890
147 2353404 1234567890
146 2353364 1234567890
145 2353324 1234567890
144 2353284 1234567890
143 2353404 1234567890
142 2353364 1234567890
141 2353324 1234567890
140 2353284 1234567890
139 2353404 1234567890
138 2353364 1234567890
137 2353324 1234567890
136 2353284 1234567890
135 2353404 1234567890
134 2353364 1234567890
133 2353324 1234567890
132 2353284 1234567890
131 2353404 1234567890
130 2353364 1234567890
129 2353324 1234567890
128 2353284 1234567890
127 2353404 1234567890
126 2353364 1234567890
125 2353324 1234567890
124 2353284 1234567890
123 2353404 1234567890
122 2353364 1234567890
121 2353324 1234567890
120 2353284 1234567890
119 2353404 1234567890
118 2353364 1234567890
117 2353324 1234567890
116 2353284 1234567890
115 2353404 1234567890
114 2353364 1234567890
113 2353324 1234567890
112 2353284 1234567890
111 2353404 1234567890
110 2353364 1234567890
109 2353324 1234567890
108 2353284 1234567890
107 2353404 1234567890
106 2353364 1234567890
105 2353324 1234567890
104 2353284 1234567890
103 2353404 1234567890
102 2353364 1234567890
101 2353324 1234567890
100 2353284 1234567890
99 2353404 1234567890
98 2353364 1234567890
97 2353324 1234567890
96 2353284 1234567890
95 2353404 1234567890
94 2353364 1234567890
93 2353324 1234567890
92 2353284 1234567890
91 2353404 1234567890
90 2353364 1234567890
89 2353324 1234567890
88 2353284 1234567890
87 2353404 1234567890
86 2353364 1234567890
85 2353324 1234567890
84 2353284 1234567890
83 2353404 1234567890
82 2353364 1234567890
81 2353324 1234567890
80 2353284 1234567890
79 2353404 1234567890
78 2353364 1234567890
77 2353324 1234567890
76 2353284 1234567890
75 2353404 1234567890
74 2353364 1234567890
73 2353324 1234567890
72 2353284 1234567890
71 2353404 1234567890
70 2353364 1234567890
69 2353324 1234567890
68 2353284 1234567890
67 2353404 1234567890
66 2353364 1234567890
65 2353324 1234567890
64 2353284 1234567890
63 2353404 1234567890
62 2353364 1234567890
61 2353324 1234567890
60 2353284 1234567890
59 2353404 1234567890
58 2353364 1234567890
57 2353324 1234567890
56 2353284 1234567890
55 2353404 1234567890
54 2353364 1234567890
53 2353324 1234567890
52 2353284 1234567890
51 2353404 1234567890
50 2353364 1234567890
49 2353324 1234567890
48 2353284 1234567890
47 2353404 1234567890
46 2353364 1234567890
45 2353324 1234567890
44 2353284 1234567890
43 2353404 1234567890
42 2353364 1234567890
41 2353324 1234567890
40 2353284 1234567890
39 2353404 1234567890
38 2353364 1234567890
37 2353324 1234567890
36 2353284 1234567890
35 2353404 1234567890
34 2353364 1234567890
33 2353324 1234567890
32 2353284 1234567890
31 2353404 1234567890
30 2353364 1234567890
29 2353324 1234567890
28 2353284 1234567890
27 2353404 1234567890
26 2353364 1234567890
25 2353324 1234567890
24 2353284 1234567890
23 2353404 1234567890
22 2353364 1234567890
21 2353324 1234567890
20 2353284 1234567890
19 2353404 1234567890
18 2353364 1234567890
17 2353324 1234567890
16 2353284 1234567890
15 2353404 1234567890
14 2353364 1234567890
13 2353324 1234567890
12 2353284 1234567890
11 2353404 1234567890
10 2353364 1234567890
9 2353324 1234567890
8 2353284 1234567890
7 2353404 1234567890
6 2353364 1234567890
5 2353324 1234567890
4 2353284 1234567890
3 2353404 1234567890
2 2353364 1234567890
1 2353324 1234567890
0 2353284 1234567890


Dulces Lunas!¡.


Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: Karcrack en 6 Enero 2012, 19:18 pm
Ha habido una confusión xD Pensaba que accedías al Integer usando un Array de Bytes :P Mi error :P


Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: x64core en 7 Enero 2012, 01:25 am

@Karcrack
si puedes cambias tu funcion segun el prototipo :P
Function MYfunction ( STR as string ) as string

de todos modos aun se pueden hacer actualizaciones hasta el dia de mañana ^^

EDIT:
Mi mov ya no sirvio T_T con el prototipo bueno para la proxima :P
Los resultados hasta ahora:



79137913:

1:0.435
2:0.432
3:0.436
4:0.430
5:0.436

BlackZeroX:

1:0.147
2:0.148
3:0.148
4:0.148
5:0.148

Elemental Code:

1:13.151
2:13.351
3:13.195
4:13.369
5:13.352

RHL:

1:0.629
2:0.632
3:0.629
4:0.629
5:0.629




Falta Karcrack que modifique el prototipo, tambien seba123neo :) o alguien mas que se desee unir al reto :)


Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: Elemental Code en 7 Enero 2012, 04:36 am
Rustico Fails :'(


Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: Karcrack en 7 Enero 2012, 14:58 pm
Código
  1. Private Static Function kGetNums(ByVal s As String) As String
  2.    Dim bv(0)   As Byte
  3.    Dim pbv     As Long
  4.    Dim rps     As Long
  5.    Dim i       As Long
  6.    Dim b       As Byte
  7.    Dim w       As Long
  8.  
  9.    kGetNums = s
  10.  
  11.    If pbv = 0 Then pbv = VarPtr(bv(0))
  12.  
  13.    rps = StrPtr(kGetNums) - pbv
  14.  
  15.    For i = 0 To LenB(kGetNums) Step 10
  16.        b = bv(rps + i + 0)
  17.        If b >= &H30 Then
  18.            If b <= &H39 Then
  19.                bv(rps + w) = b
  20.                w = w + 2
  21.            End If
  22.        End If
  23.        b = bv(rps + i + 2)
  24.        If b >= &H30 Then
  25.            If b <= &H39 Then
  26.                bv(rps + w) = b
  27.                w = w + 2
  28.            End If
  29.        End If
  30.        b = bv(rps + i + 4)
  31.        If b >= &H30 Then
  32.            If b <= &H39 Then
  33.                bv(rps + w) = b
  34.                w = w + 2
  35.            End If
  36.        End If
  37.        b = bv(rps + i + 6)
  38.        If b >= &H30 Then
  39.            If b <= &H39 Then
  40.                bv(rps + w) = b
  41.                w = w + 2
  42.            End If
  43.        End If
  44.        b = bv(rps + i + 8)
  45.        If b >= &H30 Then
  46.            If b <= &H39 Then
  47.                bv(rps + w) = b
  48.                w = w + 2
  49.            End If
  50.        End If
  51.    Next i
  52.  
  53.    bv(rps + w) = 0
  54. End Function

Deberías probar la velocidad de los códigos en unas 10000 ejecuciones... ya que ahí es donde se ve mejor la diferencia de velocidades :)


Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: seba123neo en 7 Enero 2012, 20:40 pm
Falta Karcrack que modifique el prototipo, tambien seba123neo :) o alguien mas que se desee unir al reto :)

ni hace falta la mia con RegEx es super lenta, te podes ir a comer y volver y todavia no termino, la puse simplemente por ponerla, no me acorde que era por velocidad.

yo probe las de Karcrack y BlackZeroX, ahora les paso los test, con 10 mil vueltas, con un millon y 10 millones (personalmente me gustan las funciones que siguen funcionado veloces sin importar la cantidad de interaciones que haga, algunas solo rinden en pocas iteraciones y despues en muchas se ponen lentas.)

la ultima de Karcrack, me crashea, ya le deshabilite lo de las matrices, pero igual.

saludos.


Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: 79137913 en 7 Enero 2012, 23:43 pm
HOLA!!!

Edite la funcion, cambie los ct *2 por ct + ct XD.

GRACIAS POR LEER!!!


Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: Psyke1 en 8 Enero 2012, 03:17 am
Me apunto, aunque estoy muy oxidado, mañana pongo la mía. :-\

@Karcrack
¿Por qué haces el bucle así?  :huh:

DoEvents! :P


Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: chronos682 en 8 Enero 2012, 03:52 am
De esta forma es muy lento?

Código:
Private Function GetNumbers(sText As String) As String
Dim i As Integer
Dim sTmp As String
For i = 1 To Len(sText)
    If IsNumeric(Mid$(sText, i, 1)) = True Then sTmp = sTmp & Mid$(sText, i, 1)
Next
GetNumbers = sTmp
End Function


Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: BlackZeroX en 8 Enero 2012, 06:52 am
Citar
la ultima de Karcrack, me crashea, ya le deshabilite lo de las matrices, pero igual.

De hecho a mi tambien, eso pasa por que despues de X posición esta leyendo algo que no deberia de leer... muy adelante de los 2 bytes NULOS segun la structura de BSTR, esto es por culpa de repetir sus if then y no comprobar si se deben realizar o no...

Citar
@Karcrack
¿Por qué haces el bucle así?  :huh:

Es para ahorrarse (Supongo) los jmp, cmp, etc, algo asi como {1,2,3, volver} es decir por cada 3 if then vuelve, en lugar de que cada 1 if then vuelve: Donde vuelve es una o varias instruccion(es) extra(s)...

NOTAS:
Según mi criterio y citando a karcrack que una ves me dijo apegate a las reglas y usa collection (tambien seba123neo me lo dijo, esto lo recuerdo por que apenas me tope con este comentario q°w°p).

1.- Si el prototipo explicito es: Function MYfunction(STR As String) As String
1.1.- No deberia agregarse STATIC de ninguna manera.
1.2.- Su funcion no retorna la string en ningun caso por la función.

Estos puntos son extras...
2.- Debido a que Function MYfunction(STR As String) As String.
2.1.- Es equitativo a: Function MYfunction(byref STR As String) As String mas no a byval.

Dulces Lunas!¡.


Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: Karcrack en 8 Enero 2012, 12:36 pm
El bucle esta "desenrollado":
Código:
http://en.wikipedia.org/wiki/Loop_unwinding

Respecto a lo de las reglas... tienes toda la razón, no voy a rehacer la función porque no tengo tiempo. Aún así faltó un poco más de claridad al crear el reto respecto a ese tema.. y no habiendo nada estricto sobre la declaración de la función decidí jugar un poco :P


Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: Psyke1 en 8 Enero 2012, 15:36 pm
@Black tu función me da error aquí:
Código:
wWord = thisWord(dwOffSetGet)

Código:
Subscript out range

DoEvents! :P


Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: seba123neo en 8 Enero 2012, 15:58 pm
@Black tu función me da error aquí:
Código:
wWord = thisWord(dwOffSetGet)

Código:
Subscript out range

DoEvents! :P

lo tenes que probar compilado y chequearle la opcion de "Quitar comprobaciones en limites de las matrices" en las opciones de compilacion.


Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: Psyke1 en 8 Enero 2012, 21:02 pm
@seba123neo
Gracias, culpa mía que no leí bien. ;)



Después pongo mi forma de hacerlo...

DoEvents! :P


Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: BlackZeroX en 8 Enero 2012, 23:24 pm
OJO mi función limpia sTest en otras palabras, despues de mi funcion sTest es una cadena vacia... por lo tanto deberian hacerse los test de otra menera:

por ejemplo...
Código:

    t.Reset
    For x = 1 To LOOPS
        sTest = STR
        RUSTICOnumbers_eCode sTest
    Next x


Dulces Lunas!¡.


Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: Psyke1 en 9 Enero 2012, 00:30 am
Código:
OJO mi función limpia sTest en otras palabras, despues de mi funcion sTest es una cadena vacia... por lo tanto deberian hacerse los test de otra menera:
Comprendo, ahora encaja todo... por cierto...
¿Y eso no es trampa? :huh: Se supone que sTest lo debe dejar como está, como las demás funciones, ¿no?

DoEvents! :P


Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: BlackZeroX en 9 Enero 2012, 00:48 am
Citar
¿Y eso no es trampa? :huh: Se supone que sTest lo debe dejar como está, como las demás funciones, ¿no?

Si fuese asi entonces no deberia ser byref más bien byval si es que no se quisiera modificar sTest... aun asi al no estar bien definidas las reglas se vale todo, es decir NUNCa se dice por donde retornar los datos ni que hacerle a sTest...

Dulces Lunas!¡.


Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: 79137913 en 9 Enero 2012, 02:03 am
HOLA!!!

Ejemmm hoy es ocho! y en españa ya es 9 ponganse las pilas!

GRACIAS POR LEER!!!


Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: x64core en 9 Enero 2012, 03:24 am
OJO mi función limpia sTest en otras palabras, despues de mi funcion sTest es una cadena vacia... por lo tanto deberian hacerse los test de otra menera:

por ejemplo...
Código:

    t.Reset
    For x = 1 To LOOPS
        sTest = STR
        RUSTICOnumbers_eCode sTest
    Next x


Dulces Lunas!¡.

 :¬¬
Ya veo...
bien estrictamente eso seria trampa v_v pero como el reto yo no lo especifique estrictamente PORQUE NO ME IMAGINE que esto pasaria, bueno
mas bien no recordaba/no crei que la usaran, la tecnica que usaron karcrack y BlackZeroX hoy ya no se puede hacer nada :P
De nuevo el test de todas las funciones con cadenas por valor...

HOLA!!!
Ejemmm hoy es ocho! y en españa ya es 9 ponganse las pilas!
GRACIAS POR LEER!!!

no me e podido conectar porque no e tenido red U_U
aqui en mexico faltan mas de 3 horas U_U



Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: 79137913 en 9 Enero 2012, 03:45 am
HOLA!!!

Código:
OJO mi función limpia sTest en otras palabras, despues de mi funcion sTest es una cadena vacia... por lo tanto deberian hacerse los test de otra menera:
Comprendo, ahora encaja todo... por cierto...
¿Y eso no es trampa? :huh: Se supone que sTest lo debe dejar como está, como las demás funciones, ¿no?

DoEvents! :P

+1

GRACIAS POR LEER!!!


Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: x64core en 9 Enero 2012, 05:02 am
Resultados Finales:

@Karcrack tu funcion me explotaba siempre... :P

En un for de 1000...

79137913:

1: 4.819
2: 4.662
3: 4.676
4: 4.911
5: 4.729


BlackZeroX

1: 2.637
2: 2.630
3: 2.720
4: 2.673
5: 2.634

Elemental code:

1: 134.858
2: 136.092
3: 133.272
4: 138.173
5: 133.510

RHL:

1: 7.164
2: 7.107
3: 7.183
4: 7.115
5: 7.110



Título: Re: [RETO] + Funcion Extraer Numeros de Cadenas!
Publicado por: Psyke1 en 9 Enero 2012, 10:26 am
Bueno, aquí dejo como sería la forma más rápida con RegExp por si a alguien le interesa:
Código
  1. 'cGetNums.cls
  2. Option Explicit
  3. Private oRegExp As Object
  4.  
  5. Private Sub Class_Initialize()
  6.    Set oRegExp = CreateObject("VBScript.RegExp")
  7.    With oRegExp
  8.        .Global = True
  9.        .Pattern = "\D+"
  10.    End With
  11. End Sub
  12.  
  13. Public Static Function pGetNums(ByRef sText As String) As String
  14.    pGetNums = oRegExp.Replace(sText, vbNullString)
  15. End Function
  16.  
  17. Private Sub Class_Terminate()
  18.    Set oRegExp = Nothing
  19. End Sub

Ejemplo:
Código
  1. Option Explicit
  2.  
  3. Private Sub Form_Load()
  4. Dim c As New cGetNums
  5.    Debug.Print cGetNums("0asdasd1sa sd sd 2 3  sdfdfdsf456       7!!!!!!!!!!!!!!!!!!8?????9asd")
  6.    Set c = Nothing
  7. End Sub

Resultado:
Código:
0123456789

No es muy rápida, pero bueno, tan solo participaba respetando las normas. :silbar:

DoEvents! :P