elhacker.net cabecera Bienvenido(a), Visitante. Por favor Ingresar o Registrarse
¿Perdiste tu email de activación?.

 

 


Tema destacado: Como proteger una cartera - billetera de Bitcoin


+  Foro de elhacker.net
|-+  Programación
| |-+  Programación General
| | |-+  .NET (C#, VB.NET, ASP)
| | | |-+  Programación Visual Basic (Moderadores: LeandroA, seba123neo)
| | | | |-+  [RETO] + Funcion Extraer Numeros de Cadenas!
0 Usuarios y 1 Visitante están viendo este tema.
Páginas: [1] 2 3 4 5 6 Ir Abajo Respuesta Imprimir
Autor Tema: [RETO] + Funcion Extraer Numeros de Cadenas!  (Leído 29,336 veces)
x64core


Desconectado Desconectado

Mensajes: 1.908


Ver Perfil
[RETO] + Funcion Extraer Numeros de Cadenas!
« 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:
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



« Última modificación: 6 Enero 2012, 03:04 am por RHL - 该0在 » En línea

BlackZeroX
Wiki

Desconectado Desconectado

Mensajes: 3.158


I'Love...!¡.


Ver Perfil WWW
Re: [RETO] + Funcion Extraer Numeros de Cadenas!
« Respuesta #1 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!¡.


« Última modificación: 5 Enero 2012, 00:05 am por BlackZeroX (Astaroth) » En línea

The Dark Shadow is my passion.
BlackZeroX
Wiki

Desconectado Desconectado

Mensajes: 3.158


I'Love...!¡.


Ver Perfil WWW
Re: [RETO] + Funcion Extraer Numeros de Cadenas!
« Respuesta #2 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!¡.
« Última modificación: 6 Enero 2012, 02:34 am por BlackZeroX (Astaroth) » En línea

The Dark Shadow is my passion.
W0lFy


Desconectado Desconectado

Mensajes: 551



Ver Perfil WWW
Re: [RETO] + Funcion Extraer Numeros de Cadenas!
« Respuesta #3 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!
En línea

K@NuT0
BlackZeroX
Wiki

Desconectado Desconectado

Mensajes: 3.158


I'Love...!¡.


Ver Perfil WWW
Re: [RETO] + Funcion Extraer Numeros de Cadenas!
« Respuesta #4 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!¡.
En línea

The Dark Shadow is my passion.
Karcrack


Desconectado Desconectado

Mensajes: 2.416


Se siente observado ¬¬'


Ver Perfil
Re: [RETO] + Funcion Extraer Numeros de Cadenas!
« Respuesta #5 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
En línea

79137913


Desconectado Desconectado

Mensajes: 1.169


4 Esquinas


Ver Perfil WWW
Re: [RETO] + Funcion Extraer Numeros de Cadenas!
« Respuesta #6 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!!!
« Última modificación: 7 Enero 2012, 23:42 pm por 79137913 » En línea

"Como no se puede igualar a Dios, ya he decidido que hacer, ¡SUPERARLO!"
"La peor de las ignorancias es no saber corregirlas"

 79137913                          *Shadow Scouts Team*
Elemental Code


Desconectado Desconectado

Mensajes: 622


Im beyond the system


Ver Perfil
Re: [RETO] + Funcion Extraer Numeros de Cadenas!
« Respuesta #7 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
En línea

I CODE FOR $$$
Programo por $$$
Hago tareas, trabajos para la facultad, lo que sea en VB6.0

Mis programas
x64core


Desconectado Desconectado

Mensajes: 1.908


Ver Perfil
Re: [RETO] + Funcion Extraer Numeros de Cadenas!
« Respuesta #8 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...


« Última modificación: 7 Enero 2012, 01:22 am por RHL - 该0在 » En línea

seba123neo
Moderador
***
Desconectado Desconectado

Mensajes: 3.621



Ver Perfil WWW
Re: [RETO] + Funcion Extraer Numeros de Cadenas!
« Respuesta #9 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.
« Última modificación: 5 Enero 2012, 22:47 pm por seba123neo » En línea

Páginas: [1] 2 3 4 5 6 Ir Arriba Respuesta Imprimir 

Ir a:  

WAP2 - Aviso Legal - Powered by SMF 1.1.21 | SMF © 2006-2008, Simple Machines