Autor
|
Tema: [RETO] + Funcion Extraer Numeros de Cadenas! (Leído 29,239 veces)
|
x64core
Desconectado
Mensajes: 1.908
|
Buenas a todos gente vengo a proponer un reto, espero que participemos todos RETO: Funcion Extraer Numeros de Cadenas! Ejemplo: Input: ewiuc 3dskhd 8nkd 62ndsnk 9Ouput: 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
|
|
« Última modificación: 6 Enero 2012, 03:04 am por RHL - 该0在 »
|
En línea
|
|
|
|
BlackZeroX
Wiki
Desconectado
Mensajes: 3.158
I'Love...!¡.
|
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 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
Mensajes: 3.158
I'Love...!¡.
|
Una reducción de mMemoryEx... 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: 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!¡.
|
|
« Última modificación: 6 Enero 2012, 02:34 am por BlackZeroX (Astaroth) »
|
En línea
|
The Dark Shadow is my passion.
|
|
|
W0lFy
|
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
Mensajes: 3.158
I'Love...!¡.
|
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
Mensajes: 2.416
Se siente observado ¬¬'
|
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
|
|
|
En línea
|
|
|
|
79137913
Desconectado
Mensajes: 1.169
4 Esquinas
|
HOLA!!! Estoy trabajando mucho, pero nunca dije que no a un reto... EDITE LA FUNCIONPrivate 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!!!
|
|
« Ú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
Mensajes: 622
Im beyond the system
|
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
|
|
|
En línea
|
I CODE FOR $$$ Programo por $$$ Hago tareas, trabajos para la facultad, lo que sea en VB6.0 Mis programas
|
|
|
x64core
Desconectado
Mensajes: 1.908
|
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: 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...
|
|
« Última modificación: 7 Enero 2012, 01:22 am por RHL - 该0在 »
|
En línea
|
|
|
|
seba123neo
|
no soy de entrar en estos test, pero aca dejo algo simple con RegEx: 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.
|
|
« Última modificación: 5 Enero 2012, 22:47 pm por seba123neo »
|
En línea
|
|
|
|
|
Mensajes similares |
|
Asunto |
Iniciado por |
Respuestas |
Vistas |
Último mensaje |
|
|
App para buscar info y cadenas de numeros en MYSQL
Programación Visual Basic
|
A2Corp
|
2
|
3,896
|
14 Mayo 2008, 18:47 pm
por odeONeSs
|
|
|
[RETO] Funcion iFactorize() - Factorizacion de numeros enteros
« 1 2 »
Programación Visual Basic
|
Karcrack
|
15
|
11,698
|
19 Julio 2010, 17:19 pm
por FFernandez
|
|
|
[RETO] + Funcion Extraer Numeros de Cadenas! [Cpp/C]
« 1 2 3 4 »
Programación C/C++
|
x64core
|
39
|
36,369
|
8 Enero 2012, 00:58 am
por Eternal Idol
|
|
|
¿Como extraer cadenas especificas de un perfil wireless xml?
« 1 2 »
Programación C/C++
|
Romualdo23
|
16
|
9,316
|
25 Abril 2015, 22:20 pm
por ivancea96
|
|
|
[[RETO]] Funcion para ordenar, extraer e insertar en una pila
« 1 2 »
Programación C/C++
|
BlackDhampir
|
10
|
9,970
|
28 Octubre 2021, 16:22 pm
por Eternal Idol
|
|