[SOURCE] Brute Force Dictionary Creator 7913

[79137913]

HOLA!!!

Bueno... es un creador de diccionarios ni mas ni menos, pero al trabajar con strings anda lento. Igual funciona bastante bienn .

Siguiendo... les dejo una captura, el source y el binario.

Es mas para ejemplo que para usarlo, pero si no tenemos nada funciona .

Código (vb) [Seleccionar] Expandir

Const Sym As String = "/\!·$%&/()='""¡¿?<>., :;-_*+" 'Simbolos
Const Num As String = "0123456789"                   'Numeros
Const Min As String = "abcdefghijklmnopqrstuvwxyz"   'Letras Minusculas
Const May As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"   'Letras Mayusculas
Const SpL As String = "áéíóúàèìòùâêîôûäëïöüçñ"       'Letras Especiales Minusculas
Const SpU As String = "ÁÉÍÓÚÀÈÌÒÙÊÎÔÛÄËÏÖÜÇÑ"       'Letras Especiales Mayusculas
Dim Cad As String                                    'Cadena entera de caracteres
Dim X As Long                                        'Para los Bucles

Private Sub Inicio()
Dim Letras() As String
Dim Posiciones() As Long
Dim Palabras() As String
Dim a As Long
Dim CT As Long
Dim CantPos As Long
Dim CantLet As Long
   Letras = CharSplit7913(Cad)
   CantLet = UBound(Letras)
   Open "C:\Dic7913.txt" For Output As #1
   Close #1
   ReDim Palabras(1000)
   For a = 0 To Val(MinMaxL(1).Text) - Val(MinMaxL(0).Text)
       CantPos = MinMaxL(0) + a - 1
       ReDim Posiciones(CantPos)
       Do
       For X = 0 To CantPos
           Palabras(CT) = Palabras(CT) & Letras(Posiciones(X))
       Next
       CT = CT + 1
       Posiciones(0) = Posiciones(0) + 1
       For X = 0 To CantPos - 1
           If Posiciones(X) > CantLet Then Posiciones(X) = 0: Posiciones(X + 1) = Posiciones(X + 1) + 1
       Next
       If CT = 1001 Then
           Open "C:\Dic7913.txt" For Append As #1
               For X = 0 To 1000
                   Print #1, Palabras(X)
               Next
           Close #1
           ReDim Palabras(1000)
           CT = 0
       End If
       If Posiciones(CantPos) = CantLet + 1 Then GoTo Terminado
       Loop
Terminado:
   Next
   If CT <> 0 Then
       Open "C:\Dic7913.txt" For Append As #1
           For X = 0 To CT
               Print #1, Palabras(X)
           Next
       Close #1
       CT = 0
   End If
   MsgBox "Terminado", vbInformation, "Atencion"
End Sub

Private Sub Caracteres_Click(Index As Integer)
   'Limita el checkbox de los caracteres extra si el cuadro de texto esta vacio
   If Index = 6 And Len(ExtraCHR.Text) = 0 Then Caracteres(6).Value = 0: MsgBox "El cuadro de texto de caracteres extra debe tener al menos un caracter", vbCritical, "Error"
End Sub

Private Sub Go_Click()
Dim FlagCheck As Boolean
   'Comprobacion de los minimos y maximos de longitud
   If Val(MinMaxL(0).Text) = 0 Then MsgBox "El minimo de longitud no puede ser cero", vbCritical, "Error": Exit Sub
   If Val(MinMaxL(1).Text) = 0 Then MsgBox "El maximo de longitud no puede ser cero", vbCritical, "Error": Exit Sub
   If Val(MinMaxL(0).Text) - Val(MinMaxL(1).Text) > 0 Then MsgBox "El maximo de longitud no puede ser menor que el minimo", vbCritical, "Error": Exit Sub
   'Comprobacion de los checkboxes, minimo uno debe estar tildado
   For X = 0 To 6
       If Caracteres(X).Value = 1 Then FlagCheck = True
   Next
   If FlagCheck = False Then MsgBox "Seleccione primero con que caracteres quiere hacer el diccionario", vbCritical, "Error": Exit Sub
   Cad = vbNullString 'Vacio el string Cad por si estaba lleno
   'Lleno cad con la seleccion del usuario
   If Caracteres(0).Value = 1 Then Cad = Num
   If Caracteres(1).Value = 1 Then Cad = Cad & Sym
   If Caracteres(2).Value = 1 Then Cad = Cad & Min
   If Caracteres(3).Value = 1 Then Cad = Cad & Max
   If Caracteres(4).Value = 1 Then Cad = Cad & SpL
   If Caracteres(5).Value = 1 Then Cad = Cad & SpU
   If Caracteres(6).Value = 1 Then Cad = Cad & ExtraCHR.Text
   MsgBox "El Proceso esta por Comenzar, esto podria tardar mucho tiempo para frenarlo presione Ctrl+Shift+Esc y termine el proceso, el diccionario quedara incompleto (este se guarda en c:\Dic7913.txt)", vbInformation, "Atencion - Por Comenzar"
   Call Inicio ' llamo al inicio de proceso
End Sub

Private Sub MinMaxL_KeyPress(Index As Integer, KeyAscii As Integer)
   If Not IsNumeric(Chr(KeyAscii)) Then KeyAscii = 0 'Verifica que solo se ingresen numeros en el desde hasta.
End Sub

Private Function CharSplit7913(expression As String) As String()
   Dim lExp     As Long
   Dim ExpB()   As Byte
   Dim AuxArr() As String
   ExpB = expression
   lExp = UBound(ExpB)
   ReDim AuxArr(lExp)
   For X = 0 To lExp Step 2
       AuxArr(X / 2) = ChrW(ExpB(X))
   Next
   ReDim Preserve AuxArr(Int(lExp / 2))
   CharSplit7913 = AuxArr
End Function


Descargar Source y Binario:
Mediafire

GRACIAS POR LEER!!!