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

 

 


Tema destacado: Security Series.XSS. [Cross Site Scripting]


+  Foro de elhacker.net
|-+  Programación
| |-+  Programación General
| | |-+  .NET (C#, VB.NET, ASP)
| | | |-+  Programación Visual Basic (Moderadores: LeandroA, seba123neo)
| | | | |-+  [SRC] Check_Similar_Words [by Mr. Frog ©]
0 Usuarios y 1 Visitante están viendo este tema.
Páginas: [1] 2 Ir Abajo Respuesta Imprimir
Autor Tema: [SRC] Check_Similar_Words [by Mr. Frog ©]  (Leído 4,568 veces)
Psyke1
Wiki

Desconectado Desconectado

Mensajes: 1.089



Ver Perfil WWW
[SRC] Check_Similar_Words [by Mr. Frog ©]
« en: 2 Junio 2010, 20:50 pm »

Hola a todos, os presento mi utlima funcion : Check_Similar_Words

  • ¿Que hace?
    Busca palabras similares en una cadena de texto, obtendrias un resultado similar al tipico de Google : "Quizas quiso decir... "
  • ¿Como funciona?
    Lo que hace es alamcenar en un array todas las palabras que encuentre en la cadena a analizar, una vez aqui, descompongo la palabra que se busca en las partes correspondientes a el número de coincidencias que queramos buscar, os voy a poner un ejemplo:
    Supongamos que se desea buscar la palabra "mañana", y indicamos a la funcion que busque palabras similares con 3 coincidencias, entonces se partiria la palabra a buscar de esta manera:
Citar
mañ
aña
ñan
ana
La formula para sacar el numero de fragmentos es esta:

Código:
(x - n) + 1
Donde x es la cantidad de digitos de la palabra y n los digitos en los que se quiere separar esa palabra... :D

Comprobaria si las palabras de la cadena contienen algunos de estos trozos y las guarda en mi Collection.
Lo divertido es que segun el número de coincidencias que pongamos, la busqueda sera mas o menos estricta. :laugh:

  • Bueno aqui os dejo el codigo:

Código
  1. '==================================================================================================
  2. ' º Function  : Check_Similar_Words
  3. ' º Version   : 1.2
  4. ' º Author    : Mr.Frog ©
  5. ' º Country   : Spain
  6. ' º Mail      : vbpsyke1@mixmail.com
  7. ' º Twitter   : http://twitter.com/#!/PsYkE1
  8. ' º Recommended Websites :
  9. '       http://visual-coders.com.ar
  10. '       http://InfrAngeluX.Sytes.Net
  11. '==================================================================================================
  12.  
  13. Option Explicit
  14. Option Base 0
  15.  
  16. Private Declare Function lstrcmpi Lib "kernel32" Alias "lstrcmpiA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
  17.  
  18. Public Function Check_Similar_Words(ByVal sStringToAnalyze As String, ByVal sWord As String, ByVal bvComparationLevel As Byte) As Collection
  19. Const sNullChars                                                            As String = ".,"
  20. Dim cTemp                                                                   As New Collection
  21. Dim sCompareWord()                                                          As String
  22. Dim sTextWord()                                                             As String
  23. Dim sActualWord                                                             As String
  24. Dim lTotalCompWords                                                         As Long
  25. Dim lTotalWords                                                             As Long
  26. Dim lLenWord                                                                As Long
  27. Dim Q                                                                       As Long
  28. Dim G                                                                       As Long
  29.  
  30.    If CBool(bvComparationLevel) Then
  31.        lLenWord = Len(sWord)
  32.        If (lLenWord > 2) And (Len(sStringToAnalyze) > lLenWord) Then
  33.            If (bvComparationLevel < lLenWord) Then
  34.                If Not (InStrB(sWord, vbNewLine)) Then
  35.                    G = 1
  36.  
  37.                    lTotalCompWords = (lLenWord - bvComparationLevel) + 1
  38.                    ReDim sCompareWord(lTotalCompWords) As String
  39.  
  40.                    Do Until Q = lTotalCompWords
  41.                        sCompareWord$(Q) = Mid$(sWord, G, bvComparationLevel)
  42.                        G = G + 1
  43.                        Q = Q + 1
  44.                    Loop
  45.  
  46.                    sStringToAnalyze = Replace$(sStringToAnalyze, vbNewLine, Space$(1))
  47.                    sTextWord() = Split(sStringToAnalyze, Space$(1))
  48.  
  49.                    lTotalWords = UBound(sTextWord)
  50.                    lTotalCompWords = lTotalCompWords - 1
  51.  
  52.                    For Q = 0 To lTotalWords
  53.                        sActualWord = sTextWord(Q)
  54.                        If Len(sActualWord) >= bvComparationLevel Then
  55.                            For G = 0 To lTotalCompWords
  56.                               If CBool(lstrcmpi(sWord, sActualWord)) Then
  57.                                    If InStrB(1, sActualWord, sCompareWord(G), vbTextCompare) Then
  58.                                        If InStrB(sNullChars$, Right$(sActualWord, 1)) Then
  59.                                            sActualWord = Left$(sActualWord, Len(sActualWord) - 1)
  60.                                        End If
  61.                                        On Error Resume Next
  62.                                        cTemp.Add sActualWord, sActualWord
  63.                                    End If
  64.                                End If
  65.                            Next G
  66.                        End If
  67.                    Next Q
  68.  
  69.                    Set Check_Similar_Words = cTemp
  70.                End If
  71.            End If
  72.        End If
  73.    End If
  74. End Function

  • Un ejemplo práctico:

    Tengo en un TextBox(llamado Text1) esto:
    Citar
    La inspiración de Cervantes para componer esta obra vino, al parecer, del llamado Entremés de los romances, que era de fecha anterior (aunque esto es discutido). Su argumento ridiculiza a un labrador que enloquece creyéndose héroe de romances. El labrador abandonó a su mujer, y se echó a los caminos, como hizo Don Quijote. Este entremés posee una doble lectura: también es una crítica a Lope de Vega; quien, después de haber compuesto numerosos romances autobiográficos en los que contaba sus amores, abandonó a su mujer y marchó a la Armada Invencible. Es conocido el interés de Cervantes por el Romancero y su resentimiento por haber sido echado de los teatros por el mayor éxito de Lope de Vega, así como su carácter de gran entremesista. Un argumento a favor de esta hipótesis sería el hecho de que, a pesar de que el narrador nos dice que Don Quijote ha enloquecido a causa de la lectura de libros de caballerías, durante su primera salida recita romances constantemente, sobre todo en los momentos de mayor desvarío. Por todo ello, podría ser una hipótesis verosímil. A este influjo se agregó el de Tirante el Blanco de Joanot Martorell, el del Morgante de Luigi Pulci y el del Orlando Furioso de Ludovico Ariosto.

    Para ver un ejemplo:
Código
  1. Private Sub Form_Load()
  2.    Dim vItem         As Variant
  3.  
  4.    Debug.Print "--------------->"; Time$
  5.    For Each vItem In Check_Similar_Words(Text1.Text, "argumento", 4)
  6.        Debug.Print vItem
  7.    Next vItem
  8. End Sub

Y obtengo esto:
Citar
Entremés
numerosos
resentimiento
entremesista
constantemente
momentos

En cambio si en vez de 3 pongo 4 en la llamada la busqueda de palabras similares se vuelve más extricta y obtendria esto:
Citar
resentimiento
constantemente
momentos

Espero que os haya gustado! :-*

Salu2! :P


« Última modificación: 10 Enero 2011, 02:20 am por Mr. Frog © » En línea

e500

Desconectado Desconectado

Mensajes: 83


Ver Perfil
Re: [SRC] + [Function] Check_Similar_Words [by *PsYkE1*]
« Respuesta #1 en: 4 Junio 2010, 00:58 am »

Muy interesante,  ;-)

Saludos :)


En línea

Psyke1
Wiki

Desconectado Desconectado

Mensajes: 1.089



Ver Perfil WWW
Re: [SRC] + [Function] Check_Similar_Words [by *PsYkE1*]
« Respuesta #2 en: 2 Julio 2010, 11:51 am »

Atención:
He corregido testeado y optimizado el Source!!! :P

Salu2! ;)
En línea

Komodo


Desconectado Desconectado

Mensajes: 352



Ver Perfil
Re: [SRC] + [Function] Check_Similar_Words [by *PsYkE1*]
« Respuesta #3 en: 2 Julio 2010, 12:24 pm »

Lo probaré, porque no me ha quedado del todo claro.
En línea


Psyke1
Wiki

Desconectado Desconectado

Mensajes: 1.089



Ver Perfil WWW
Re: [SRC] + [Function] Check_Similar_Words [by *PsYkE1*]
« Respuesta #4 en: 2 Julio 2010, 12:27 pm »

Ok, ¿que es lo que no te quedo claro?

Salu2! ;)
En línea

Komodo


Desconectado Desconectado

Mensajes: 352



Ver Perfil
Re: [SRC] + [Function] Check_Similar_Words [by *PsYkE1*]
« Respuesta #5 en: 2 Julio 2010, 14:41 pm »

Una de las cosas es lo que ponía antes de que lo corrigieras, ahora si.

Ya lo he pillado..

Mira he puesto esto:

Text1-> Lo que hace es alamcenar en un array todas las palabras que encuentre en la cadena a analizar, una vez aqui, descompongo la palabra que se busca en las partes correspondientes a el número de coincidencias que queramos buscar, os voy a poner un ejemplo:

sWord -> "enjambre" ---->si lComparationLevel = 1 --->la palabra que sale es "ejemplo"
                                ---->si lComparationLevel = 2 --->la palabra que sale es "queramos"     


Un poco raro xD pero bueno ;)

:P Buen code.


En línea


Psyke1
Wiki

Desconectado Desconectado

Mensajes: 1.089



Ver Perfil WWW
Re: [SRC] + [Function] Check_Similar_Words [by *PsYkE1*]
« Respuesta #6 en: 2 Julio 2010, 14:51 pm »

Revisa el SRC que lo he cambiado 30 veces despues de postearlo... :xD
No me sale lo mismo que a ti... :-\

Me sale esto si pongo 1:
Citar
que
hace
es
alamcenar
en
un
array
todas
las
palabras
encuentre
la
cadena
a
analizar
una
vez
aqui
descompongo
palabra
se
busca
partes
correspondientes
el
número
de
coincidencias
queramos
buscar
poner
ejemplo

Y si pongo 2:
Citar
alamcenar
en
palabras
encuentre
cadena
palabra
correspondientes
coincidencias
queramos

No obstante poner los valores 1 o 2, es una chorrada, porque el nivel de exigencia seria demasiado bajo... :¬¬
Corregi el SRC, ahora solo se puede poner el valor 3 como minimo... :P

Salu2 y Gracias! ;)
« Última modificación: 2 Julio 2010, 15:18 pm por *PsYkE1* » En línea

cobein


Desconectado Desconectado

Mensajes: 759



Ver Perfil WWW
Re: [SRC] + [Function] Check_Similar_Words [by *PsYkE1*]
« Respuesta #7 en: 2 Julio 2010, 15:40 pm »

MIra esto
http://en.wikipedia.org/wiki/Levenshtein_distance
En línea

http://www.advancevb.com.ar
Más Argentino que el morcipan
Aguante el Uvita tinto, Tigre, Ford y seba123neo
Karcrack es un capo.
Komodo


Desconectado Desconectado

Mensajes: 352



Ver Perfil
Re: [SRC] + [Function] Check_Similar_Words [by *PsYkE1*]
« Respuesta #8 en: 2 Julio 2010, 16:00 pm »

aaahh ya lo pillo yo tengo puesto esto en mi code:

Código
  1. Private Sub Form_Load()
  2.    Dim vItem         As Variant
  3.    Dim sString       As String
  4.  
  5.    sString = Text1.Text
  6.    For Each vItem In Check_Similar_Words(sString, "agua", 1)
  7.        Debug.Print vItem
  8.        Text2.Text = vItem
  9.    Next vItem
  10.  
  11. End Sub

Citar
Text2.Text = vItem

ese es el error, como lo pones tú?
En línea


Psyke1
Wiki

Desconectado Desconectado

Mensajes: 1.089



Ver Perfil WWW
Re: [SRC] + [Function] Check_Similar_Words [by *PsYkE1*]
« Respuesta #9 en: 2 Julio 2010, 16:11 pm »

aaahh ya lo pillo yo tengo puesto esto en mi code:

Código
  1. Private Sub Form_Load()
  2.    Dim vItem         As Variant
  3.    Dim sString       As String
  4.  
  5.    sString = Text1.Text
  6.    For Each vItem In Check_Similar_Words(sString, "agua", 1)
  7.        Debug.Print vItem
  8.        Text2.Text = vItem
  9.    Next vItem
  10.  
  11. End Sub

Citar
Text2.Text = vItem

ese es el error, como lo pones tú?
NoO0 :xD
Text2??  :huh:
Actualmente si abres un proyecto y copias y pegas el codigo funciona bien, no tienes que cambiar nada... :P
Wow! :o
Me parece interesantisimo!! ;-)
Al hacer la funcion me tuve yo que inventar el logaritmo... :silbar:

Salu2! ;)
« Última modificación: 2 Julio 2010, 16:17 pm por *PsYkE1* » En línea

Páginas: [1] 2 Ir Arriba Respuesta Imprimir 

Ir a:  

Mensajes similares
Asunto Iniciado por Respuestas Vistas Último mensaje
[SRC] FrogCheat v1.1 [by Mr. Frog ©] « 1 2 3 »
Programación Visual Basic
Psyke1 28 10,710 Último mensaje 6 Enero 2011, 18:13 pm
por ssccaann43 ©
[SRC] [Tip] AlignListBox [by Mr. Frog ©]
Programación Visual Basic
Psyke1 3 1,577 Último mensaje 13 Diciembre 2010, 03:36 am
por agus0
[SRC] cListBoxMultiAlign [by Mr. Frog ©] « 1 2 »
Programación Visual Basic
Psyke1 11 3,636 Último mensaje 16 Diciembre 2010, 20:40 pm
por Psyke1
[SRC] cFrogContest.cls [by Mr. Frog ©] « 1 2 »
Programación Visual Basic
Psyke1 12 4,933 Último mensaje 12 Febrero 2011, 22:29 pm
por Psyke1
[SRC] IIfEx [by Mr. Frog ©]
Programación Visual Basic
Psyke1 2 1,181 Último mensaje 11 Febrero 2011, 15:15 pm
por Psyke1
WAP2 - Aviso Legal - Powered by SMF 1.1.21 | SMF © 2006-2008, Simple Machines