[SOURCE] Brute Force Dictionary Creator 7913

    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