h0ax 
Este es el código básico del programa que se encuentra en la carpeta Tool. El ejecutable tiene otras opciones como son ajustar el tamaño del cuadro de texto cuando la ventana se cambia de tamaño, mostrar una pequeña y ayuda para saber más sobre su uso y cosas por el estilo, sin embargo, el fragmento que realiza toda el procedimiento real del programa es el que se expone aquí.
Importante: La clave para codificar, al igual que la que realiza la operación inversa debe tener los números del 1-6 sin repetir u omitir ninguno.
Aunque la clave de codificación sea útil, no es la que decodifica el mensaje, ya que sería muy fácil entonces robar la clave y poder ver el mensaje como tal. Para decodificarlo, lo que se tiene que hacer es reordenar la clave. Supongamos que se codifico con 163245, la clave de decodificación sería en tonces: 143562, ¿por qué?.
Para saberlo lo que tenemos que decir es:
Clave con que se codificó: 163245.
¿En que posición está el 1? –> 1
¿En que posición está el 2? –> 4
¿En que posición está el 3? –> 3
¿En que posición está el 4? –> 5
¿En que posición está el 5? –> 6
¿En que posición está el 6? –> 2
Entonces la clave de decodificación sería: 143562. De esa forma se asegura que cualquiera que obtenga la clave no la pueda usar si no tiene este método.
Private Sub codificar_Click()
Dim clave As String
clave = InputBox("Escriba la clave con al que desea encriptar el mensaje, tenga en cuenta que debe contener los números del 1 al 6 y sin que se repita ninguno de estos", "Clave")
If clave = "" Then Exit Sub
If Len(clave) <> 6 Then
MsgBox "La clave no tienes los caracteres requeridos. Verifíquela", vbCritical
Exit Sub
End If
Dim Faltan As Integer
'Para saber cuántos caracteres faltan hasta que la cantidad sea múltiplo de 6.
Faltan = 6 * (Int(Len(Text1.Text) / 6) + 1) - Len(Text1.Text)
'Hacer el ciclo para añadir los espacios que faltan hasta que el texto sea multiplo de 6
For i = 1 To Faltan
Text1.Text = Text1.Text & " "
Next
'Limpia las listas en caso de que tengan algo escrito
List1.Clear
List2.Clear
'Ciclo que recorre el texto haciendo grupos de 6 y los coloca en la lista1
Dim grupo As String
For i = 1 To Len(Text1.Text) Step 6
grupo = Mid(Text1.Text, i, 6)
List1.AddItem (grupo)
Next
'Encriptar
Dim Palabra_Normal As String
Dim Palabra_Encriptada As String
For i = 0 To List1.ListCount - 1
Palabra_Normal = List1.List(i)
'Se le aplica la codificación a la palabra segun el método
Palabra_Encriptada = Mid(Palabra_Normal, Int(Mid(clave, 1, 1)), 1) & Mid (Palabra_Normal, Int(Mid(clave, 2, 1)), 1) & Mid(Palabra_Normal, Int(Mid(clave, 3, 1)), 1) & Mid(Palabra_Normal, Int(Mid(clave, 4, 1)), 1) & Mid(Palabra_Normal, Int(Mid(clave, 5, 1)), 1) & Mid(Palabra_Normal, Int(Mid(clave, 6, 1)), 1)
List2.AddItem Palabra_Encriptada
Next
'Se vacíia el texto donde se va a poner el contenido ya encriptado
Text1.Text = ""
Dim inicio As String
Dim fin As String
For i = 0 To List2.ListCount - 1
If Text1.Text = "" Then
Text1.Text = List2.List(i)
Else
inicio = Mid(Text1.Text, 1, Len(Text1.Text) / 2)
fin = Mid(Text1.Text, Len(Text1.Text) / 2 + 1, Len(Text1.Text))
Text1.Text = inicio & List2.List(i) & fin
End If
Next
End Sub
//-----------------------------------------------------------------------------------------------
Private Sub decodificar_Click()
Dim clave As String
clave = InputBox("Escriba la clave con la que se encripto este mensaje, tenga en cuenta que debe contener los números del 1 al 6 y sin que se repita ninguno de estos", "Clave")
If clave = "" Then Exit Sub
'Limipio la lista
List1.Clear
Text1.Text = Mid(Text1.Text, 7, Len(Text1.Text))
For i = 1 To Len(Text1.Text) / 2 Step 3
List1.AddItem Mid(Text1.Text, i, 3) & Mid(Text1.Text, Len(Text1.Text) - (i + 1), 3)
Next
Text1.Text = ""
Dim Palabra_Encriptada As String
Dim Palabra_Normal As String
For i = 0 To List1.ListCount - 1
Palabra_Encriptada = List1.List(i)
'Se le aplica la decodificación a la palabra segun el método
Palabra_Normal = Mid(Palabra_Encriptada, Int(Mid(clave, 1, 1)), 1) & Mid(Palabra_Encriptada, Int(Mid(clave, 2, 1)), 1) & Mid(Palabra_Encriptada, Int(Mid(clave, 3, 1)), 1) & Mid(Palabra_Encriptada, Int(Mid(clave, 4, 1)), 1) & Mid(Palabra_Encriptada, Int(Mid(clave, 5, 1)), 1) & Mid(Palabra_Encriptada, Int(Mid(clave, 6, 1)), 1)
'Se va guardando en el texto
Text1.Text = Text1.Text & Palabra_Normal
Next
End Sub
Escrito por Alien [blackhat4all@gmail.com]
