Rutina de encriptamiento

Jose luis
12 de Mayo del 2003
Necesito una rutina que encripte los datos y los guarde a la BD y las desencripte y los muestre, alguien sabe de alguna, alguien me puede ayudar necesito ayuda

Santos Pairazam?
12 de Mayo del 2003
Aqui estan algunas Funciones - espero llegue completo sino me mandas un Email
'//-------------- Funcion que convierte un numero HexaDecimal a Decimal ---------------------------//
Function Dec(isHex)
isHex = UCase(isHex)
If Len(isHex) <> 2 Then
Dec = -1
Exit Function
End If
Dim lsCaracter1,lsCaracter2,lnCaracter1,lnCaracter2

lsCaracter1 = Mid(isHex, 2, 1)
lsCaracter2 = Mid(isHex, 1, 1)
If (lsCaracter1 < "0" Or lsCaracter1 > "9") And (lsCaracter1 < "A" Or lsCaracter1 > "F") Then
Dec = -1
Exit Function
End If
If (lsCaracter2 < "0" Or lsCaracter2 > "9") And (lsCaracter2 < "A" Or lsCaracter2 > "F") Then
Dec = -1
Exit Function
End If
If (lsCaracter1 >= "0" And lsCaracter1 <= "9") Then
lnCaracter1 = Asc(lsCaracter1) - Asc("0")
ElseIf (lsCaracter1 >= "A" And lsCaracter1 <= "F") Then
lnCaracter1 = 10 + Asc(lsCaracter1) - Asc("A")
End If
If (lsCaracter2 >= "0" And lsCaracter2 <= "9") Then
lnCaracter2 = Asc(lsCaracter2) - Asc("0")
ElseIf (lsCaracter2 >= "A" And lsCaracter2 <= "F") Then
lnCaracter2 = 10 + Asc(lsCaracter2) - Asc("A")
End If
Dec = 16 * lnCaracter2 + lnCaracter1
End Function

'//-------------- funcion que Invierte la Cadena -----------------------------------------//
Public Function Invertir(isCadena )
Dim lnLongitud
lnLongitud = Len(isCadena)
If lnLongitud = 0 Then
Invertir = ""
Exit Function
End If
If lnLongitud = 1 Then
Invertir = isCadena
Exit Function
End If
Invertir = Mid(isCadena, lnLongitud, 1) & Invertir(Mid(isCadena, 1, lnLongitud - 1))
End Function

'//-------------- Funcion que Encripta la Cadena -----------------------------------------//
Public Function Encriptar(isCadena)
Dim lnContador,lnLongitud,lnCaracterRnd,lnCaracterEnc,lnCaracter,lsCadenaEnc
Randomize
lnLongitud = Len(iscadena)
For lnContador = 1 To lnLongitud
lnCaracter = Asc(Mid(iscadena, lnContador, 1))
lnCaracterRnd = Int(256 * Rnd())
Do Until lnCaracterRnd <> 0 And _
lnCaracterRnd <> 8 And _
lnCaracterRnd <> 9 And _
lnCaracterRnd <> 10 And _
lnCaracterRnd <> 13 And _
(lnCaracter + lnCaracterRnd) Mod 256 <> 0 And _
(lnCaracter + lnCaracterRnd) Mod 256 <> 8 And _
(lnCaracter + lnCaracterRnd) Mod 256 <> 9 And _
(lnCaracter + lnCaracterRnd) Mod 256 <> 10 And _
(lnCaracter + lnCaracterRnd) Mod 256 <> 13
lnCaracterRnd = Int(256 * Rnd())
Loop
lnCaracterEnc = (lnCaracter + lnCaracterRnd) Mod 256
lsCadenaEnc = lsCadenaEnc + Right("00" + Hex(lnCaracterRnd), 2) + Right("00" + Hex(lnCaracterEnc), 2)
Next
Encriptar = Invertir(lsCadenaEnc)
End Function

'//---------------- Funcion que Desencripta -------------------------------------------------------//
Function Desencriptar (iscadena)
Dim lnContador, lnLongitud, lnAscii,lsCaracterRnd, lsCaracterDes, lsCaracter, lsCadenaEnc, lsCadenaDes
lsCadenaEnc = Invertir(iscadena)
lnLongitud = Len(lsCadenaEnc) / 2
If lnLongitud Mod 2 <> 0 Then
Desencriptar = ""
Exit Function
End If
For lnContador = 1 To lnLongitud Step 2
lsCaracterRnd = Chr(dec(Mid(lsCadenaEnc, 2 * lnContador - 1, 2)))
lsCaracter = Chr(dec(Mid(lsCadenaEnc, 2 * lnContador + 1, 2)))
lnAscii = (Asc(lsCaracter) - Asc(lsCaracterRnd)) Mod 256
If lnAscii < 0 Then
lsCaracterDes = Chr(256 + lnAscii)
Else
lsCaracterDes = Chr(lnAscii)
End If
lsCadenaDes = lsCadenaDes + lsCaracterDes
Next
Desencriptar = lsCadenaDes
End function
Lo puedes llamar asi
password2 = trim(rsUser("password"))
password2 = Desencriptar(password2 )