[RETO] + Funcion Extraer Numeros de Cadenas!

[x64core]

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:
NO vale asm inline, ni ninguna magia negra ni blanca ,a puro code vb, funct vb, apis, clases

Vamos Participemos todos!



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

[BlackZeroX]

Código (vb) [Seleccionar] Expandir



Private Sub Form_Load()
Dim szCadena As String
Dim szBuffer As String

   szBuffer = Space(20)
   szCadena = "ewiuc3dskhd8nkd62ndsnk9"
   
   mMemoryEx.initialize
   MsgBox getNumbers(szCadena, szBuffer)
   MsgBox szBuffer

End Sub

Private Function getNumbers(ByRef szIn As String, ByRef szBuffer As String)
Dim lnBuff  As Long
Dim iRet    As Long
Dim lpIn    As Long
Dim lpBuff  As Long
Dim word    As Integer

   lnBuff = Len(szBuffer)
   
   If (Len(szIn) = 0) Then
       getNumbers = iRet
       Exit Function
   End If
   
   lpIn = StrPtr(szIn)
   lpBuff = StrPtr(szBuffer)
   
   Do
       If (lnBuff = 0) Then Exit Do
       word = mMemoryEx.getWord(lpIn)
       
       If (word >= 48 And 57 >= word) Then
           iRet = (iRet + 1)
           'Mid$(szBuffer, iRet, 1) = Chr(word)
           mMemoryEx.putWord lpBuff, word
           lnBuff = (lnBuff - 1)
           lpBuff = (lpBuff + 2)
       End If
       
       lpIn = (lpIn + 2)
       
   Loop While (word > 0)
   
   getNumbers = iRet
   
End Function



mMemoryEx.bas

Código [Seleccionar] Expandir



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

[BlackZeroX]

Una reducción de mMemoryEx...

Código (vb) [Seleccionar] Expandir



Private Function getNumbers2(ByRef sIn As String, ByRef sOut As String) As Long
Dim thisWord(0) As Integer  '   //  Un caracter = 2 bytes = integer
Dim dwOffSetGet As Long     '   //  Offset Get caracter...
Dim dwOffSetSet As Long     '   //  Offset Set caracter...
Dim wWord       As Integer  '   //  Letra en asc...
Dim dwRet       As Integer  '   //  Cantidad de digitos encontrados...
Dim dwLenI      As Long     '   //  Longitud en bytes de sIn...
Dim dwLenB      As Long     '   //  Longitud en bytes de sOut...
Dim dwOffset    As Long     '   //  Offset del Buffer...

    dwOffSetGet = (StrPtr(sIn) - VarPtr(thisWord(0))) \ 2
    dwLenB = LenB(sOut)

    If (dwLenB) Then
        dwOffSetSet = (StrPtr(sOut) - VarPtr(thisWord(0))) \ 2
    End If
    dwLenI = LenB(sIn)

    If (dwLenI) Then
        Do
            If (dwLenI And &H80000000) Then Exit Do

            wWord = thisWord(dwOffSetGet)

            If (wWord >= &H30) Then
                If (wWord <= &H39) Then
                    dwRet = (dwRet + 1)
                    If (dwLenB) Then
                        thisWord(dwOffSetSet) = wWord
                        dwOffSetSet = (dwOffSetSet + 1)
                        dwLenB = (dwLenB - 2)
                    End If
                End If
            End If

            dwOffSetGet = (dwOffSetGet + 1)
            dwLenI = (dwLenI - 2)

        Loop While (wWord > 0)
    End If

    thisWord(dwOffSetSet) = &H0&
    getNumbers2 = dwRet

End Function



o tambien asi:

Código (vb) [Seleccionar] Expandir



Option Explicit

Private Sub Form_Load()
Dim szCadena As String
Dim szBuffer As String
Dim lnBuffer As Long

    szCadena = "sdh!w2 28 :-)  9ndk#1@b______dy0--hveybd@  # qism083  s'kl...: su2b7h ++bjsnbvxj77ygv1hiiiioms90nms sjbah b#!1!  --R-E-D--0+-w++ONE***WWW."
    lnBuffer = getNumbers(szCadena, vbNullString)
    szBuffer = Space(lnBuffer)
    MsgBox "Se Obtubieron " & getNumbers(szCadena, szBuffer) & " de " & lnBuffer & vbCrLf & szBuffer
End Sub

Private Function getNumbers(ByRef szIn As String, ByRef szBuffer As String) As Long
Dim lnBuff      As Long
Dim lnIn        As Long
Dim iRet        As Long
Dim lPosIn      As Long
Dim lPosBuff    As Long
Dim word        As Integer

    lnBuff = LenB(szBuffer)
    lnIn = LenB(szIn)

    If (Len(szIn) = 0) Then
        getNumbers = iRet
        Exit Function
    End If

    lPosIn = &H1
    lPosBuff = &H1

    Do
        If (lnIn <= lPosIn) Then Exit Do
        word = Asc(MidB(szIn, lPosIn, 2))

        If (word >= 48 And 57 >= word) Then
            iRet = (iRet + 1)
            If (lnBuff) Then
                MidB(szBuffer, lPosBuff, 2) = Chr(word)
                lnBuff = (lnBuff - 2)
            End If
            lPosBuff = (lPosBuff + 2)
        End If

        lPosIn = (lPosIn + 2)

    Loop While (word > 0)

    getNumbers = iRet

End Function



Dulces Lunas!¡.

[W0lFy]

es un sistema de cifrado? me ha llamado la atencion por que yo ando haciendo tambien algoritmos de cifrado. Un saludo!

[BlackZeroX]

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

[Karcrack]

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

[79137913]

HOLA!!!

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

EDITE LA FUNCION

Código (vb) [Seleccionar] Expandir

Private Function ExtractNums7913(expression As String) As String
   Dim a() As Byte
   Dim b() As Byte
   Dim ct As Long
       a = expression
       b = a
       For x = 0 To UBound(a) Step 2
           If a(x) < 58 Then
               If a(x) > 47 Then
                   b(ct + ct) = a(x)
                   ct = ct + 1
               End If
           End If
       Next
       ReDim Preserve b(ct + ct)
       ExtractNums7913 = b
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!!!

[Elemental Code]

RUSTICO MODE ON!

Código (vb) [Seleccionar] Expandir

Function RUSTICOnumbers_eCode(ByRef sSTR As String) As String
    Dim i As Integer
    Dim x As String * 1
    For i = 1 To Len(sSTR)
    x = Mid(sSTR, i, 1)
        Select Case x
            Case 0 To 9
                RUSTICOnumbers_eCode = RUSTICOnumbers_eCode & x
        End Select
    Next
End Function

[x64core]

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

La verdad fue error mio al no aclarar que tipo de variable deberia devolver y si lo modifico ya no tendria sentido



Aqui esta la mia:

Código (vb) [Seleccionar] Expandir


Option Explicit


Private Declare Sub MOV Lib "ntdll.dll" Alias "#1042" _
(d As Any, s As Any, ByVal l As Long)

Private Function GetNums(RetSTR As String) As String
Dim lpStr       As Long
Dim lpret       As Long
Dim ln          As Long
Dim b           As Long
Dim t           As Integer

    GetNums = RetSTR
    lpStr = StrPtr(GetNums): lpret = lpStr
    ln = LenB(GetNums)

    For lpStr = lpStr To (lpStr + ln) Step &H2
        MOV t, ByVal lpStr, &H2
        If (t >= &H30) Then
            If (t <= &H39) Then
                MOV ByVal lpret + b, t, &H2
                b = b + &H2
            End If
        End If
    Next
   
    MOV ByVal lpret + b, &H0, &H2
    MOV ByVal (lpret - &H4), b, &H4
End Function






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...

[seba123neo]

no soy de entrar en estos test, pero aca dejo algo simple con RegEx:

Código (vb) [Seleccionar] Expandir

Private Sub Form_Load()
   Dim i As String
   i = "sdh!w2 28 :-)  9ndk#1@b______dy0--hveybd@  # qism083  s'kl...: su2b7h ++bjsnbvxj77ygv1hiiiioms90nms sjbah b#!1!  --R-E-D--0+-w++ONE***WWW."
   
   Dim obj_Expresion As Object
   Set obj_Expresion = CreateObject("VBScript.RegExp")

   obj_Expresion.Pattern = "\d+"
   obj_Expresion.IgnoreCase = True
   obj_Expresion.Global = True

    Dim ExtractNumbers As Object
   Set ExtractNumbers = obj_Expresion.Execute(i)
 
   Dim ii As Long
   For ii = 0 To ExtractNumbers.Count - 1
       Debug.Print ExtractNumbers(ii)
   Next
End Sub

saludos.