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
