' Funcion Encriptar()
' 6/Jun/2007, Mexicali, BC, Mexico
' Jose Agustin Hernandez M, aka Semper (
www.canalvisualbasic.Net)
'
semperfimxl@gmail.com
'
' Urbi Et Orbi
'
' Esta funcion retorna una cadena Codificada (Encriptada) de longitud
' variable construida a partir de una cadena cualquiera con un
' minimo de 1 caracter.
' La cadena codificada que se retorna NO ES ALEATORIA: se construye
' a partir de la conversion a valores LONG de la cadena original y
' reconvirtiendo dichos valores LONG en cadena (String) nuevamente.
' El resultado encriptado es SIEMPRE EL MISMO para una combinacion de
' "frase original/metodo usado" especifica ...
' Dado el procedimiento utilizado en el proceso, la cadena Encriptada
' muy dificilmente podra Desencriptarse para obtener la frase original,
' lo que nos pone a salvo de curiosos tratando de descrifrar el resultado.
'
' Los metodos para encriptar se enumeran mas abajo ...
'
' Aunque resulte obvio, no esta de mas aclarar que el metodo a usar para
' validar una contraseña, debera ser el mismo que se uso originalmente
' para obtener la contraseña cifrada ..
'
'
'
' Ejemplo (muy simple) de uso:
' - En nuestra seccion de alta/cambios de usuarios, le pedimos al ADMIN que
' proporcione la clave de usuario a registrar (textUsuario) y la contraseña
' que le asignara al mismo (textPassword).
' Guardamos el nombre de usuario y la
' contraseña codificada en la tabla correspondiente en la base de datos ...
'
' rsUsuarios.AddNew
' rsUsuarios.Fields("Usuario") = textUsuario
' rsUsuarios.Fields("Contrasena") = Encriptar(textPassword, MetodoDeseado)
' rsUsuarios.Update
'
'



' - Cuando el usuario ingresa al sistema, abrimos una ventana donde le
' pedimos su nombre de usuario y su contraseña ...
' Buscamos el usuario en la tabla correspondiente, y si existe, validamos
' que la contraseña que nos dio corresponda con la contraseña codificada
' que tenemos almacenada ...
' Si no existe el usuario especificado o la contraseña no corresponde
' no permitimos el acceso.
' Si tenemos coindicencia en ambos datos, le abrimos el acceso al sistema
'
' Set rsUsuarios = Db.OpenRecordset("SELECT * FROM Usuarios WHERE _
' Usuario = '" & textUsuario & "'")
' If Not rsUsuarios.Eof Then
' rsUsuarios.MoveFirst
' If rsUsuarios.Fields("Contrasena") = Encriptar(textPassword, MetodoDeseado) Then
' ' ... Lo que deseemos hacer antes de darle acceso ...
' rsUsuarios.Close
' Set rsUsuarios = Nothing
' MsgBox "Bienvenido Al Sistema !"
' FormPrincipal.Show
' Unload Me
' Exit Sub
' End If
' End If
'
' MsgBox "El Usuario o la Contraseña Son Incorrectos !"
'
'
' - Por supuesto deberemos tener un proceso para que el propio usuario
' pueda cambiar su contraseña por otra de su predileccion.
' En este caso, como en cualquier sistema de seguridad, le pediriamos al
' usuario su contraseña actual (validamos que sea correcta para evitar
' que un tercero sea el que la cambie sin conocimiento del usuario), asi
' como la nueva contraseña deseada...
' Con los datos proporcionados, actualizamos su registro en la tabla
' de usuarios del sistema....
'
'
' Todo esto lo ponen en un modulo estandard (.BAS )
'
' Comentarios? Sugerencias?
'
''''''''''''''''''''''''''''''''



Option Explicit


Public Enum Encriptar_Usando
EU_Mayusc_Y_Numeros = 1
EU_Minusc_Y_Numeros = 2
EU_Mayusc_Minusc_Y_Numeros = 4
EU_Cualquier_Desplegable = 8
End Enum



Public Function Encriptar(ByVal sPassword As String, Optional EU_Metodo As Encriptar_Usando = EU_Cualquier_Desplegable) As String
Dim nCol As Byte
Dim nPos As Long, nLimite As Byte
Dim sCadenaHex As String
Dim aValoresLong() As Long, nValorLong As Long
Dim sCadenaLong As String

ReDim aValoresLong(1 To 1)

If Len(sPassword) = 0 Then Exit Function ' Nada que hacer ...

' Forzamos la cadena a una longitud multiplo de 8 para encriptar
' Cada caracter adicionado se conforma de la suma del valore ASCII
' de cada caracter en la cadena previa, verificando obviamente
' que dicha suma no rebase el limite de 255

nPos = Asc(Right(sPassword, 1)) * 2
Do While (Int(Len(sPassword) / 8) * 8) <> Len(sPassword)
For nCol = 1 To Len(sPassword)
nPos = nPos + Asc(Mid(sPassword, nCol, 1))
Next
Do While nPos > 255
nPos = nPos - 255
Loop
Do While nPos < 32
nPos = nPos + 32
Loop

sPassword = sPassword & Chr(nPos)
nPos = 0
Loop

' Convertimos la cadena PASSWORD en una matriz de valores long
' procesando cada 4 caracteres de la cadena ...

' Para convertir en valor LONG una cadena "x" esta debe tener
' un maximo de cuatro caracteres de longitud ...
' (cinco o mas caracteres provocan un OVERFLOW o Desbordamiento)

nPos = 1: nLimite = 4

Do While nPos <= Len(sPassword)
If ((nPos + nLimite) - 1) > Len(sPassword) Then
nLimite = Len(sPassword) - (nPos - 1)
End If

' Convertimos la subcadena en cadena de valores HEXAdecimales
sCadenaHex = ""
For nCol = 1 To nLimite
sCadenaHex = sCadenaHex & _
Hex(Asc(Mid(sPassword, (nPos + nCol) - 1, 1)))
Next


' El valor LONG final lo obtenemos convirtiendo en long
' la cadena de valores HEXAdecimales, usando el prefijo "&h"

nValorLong = CLng("&h" & sCadenaHex)

' Si el LONG resultante fuera negativo, forzamos a positivo
If nValorLong < 0 Then
nValorLong = nValorLong * -1
End If

'Agregamos el valor obtenido a la matriz de valores long
If aValoresLong(UBound(aValoresLong)) <> 0 Then
ReDim Preserve aValoresLong(1 To UBound(aValoresLong) + 1)
End If

aValoresLong(UBound(aValoresLong)) = nValorLong

nPos = nPos + nLimite
Loop

' Ya tenemos la matriz de valores long ...
' Recorremos la misma convirtiendo los valores almacenados en una
' cadena numerica unica ...
sCadenaLong = ""
For nPos = 1 To UBound(aValoresLong)
sCadenaLong = sCadenaLong & CStr(aValoresLong(nPos))
Next

' Reprocesamos la cadena numerica convirtiendo cada dos o tres caracteres
' en un codigo ASCII para obtener la Encriptacion final

Encriptar = ""
nPos = 1

Do While nPos <= Len(sCadenaLong)
If CInt(Mid(sCadenaLong, nPos, 3)) > 255 Then
nCol = CByte(Mid(sCadenaLong, nPos, 2))
nPos = nPos + 2
Else
nCol = CByte(Mid(sCadenaLong, nPos, 3))
nPos = nPos + 3
End If

If nCol < 1 Then nCol = 33

Do While nCol < 33 ' no obtener caracteres de control ni espacios
nCol = nCol + nCol
Loop

If EU_Metodo = EU_Cualquier_Desplegable Then
If nCol = 255 Then nCol = 65

ElseIf nCol < 48 Then
Do While nCol < 48
nCol = nCol + 10
Loop

ElseIf nCol > 57 And nCol < 65 Then
nCol = nCol - 7

ElseIf EU_Metodo = EU_Mayusc_Minusc_Y_Numeros Then
If nCol > 90 And nCol < 97 Then
nCol = nCol - 6
Else
Do While nCol > 122
nCol = nCol - 26
Loop
End If

ElseIf EU_Metodo = EU_Mayusc_Y_Numeros Then
Do While nCol > 90
nCol = nCol - 26
Loop

ElseIf EU_Metodo = EU_Minusc_Y_Numeros Then
Do While nCol < 97
nCol = nCol + 26
Loop

Do While nCol > 122
nCol = nCol - 26
Loop
End If

Encriptar = Encriptar & Chr(nCol)
Loop

End Function


''''''''''''''''''''''''''''