Dim WithEvents
13/12/2021
Sencillo sistema de gestión documental
15/12/2021
Esta función permite encriptar y desencriptar una cadena de texto usando el método Rot13.
Texto original: Angel Gil
Nivel: Principante
¿Cómo funciona?
EXPLICACIÓN DEL FUNCIONAMIENTO
En ocasiones necesitamos encriptar la información de algún campo y guardarlo en la tabla de forma que sea ilegible para el que acceda a él directamente. Esta función precisamente se encarga tanto de encriptar el texto que se le pasa como argumento como de desencriptarlo.
Código:
Function CodRot13(CadenaEnviada As String)
'---------------------------------------------------------------------------------------
Fuente : https://access-global.net/encriptar-una-cadena-de-texto
'---------------------------------------------------------------------------------------
' Título : Encriptar cadena de texto
' Autor original : Desconocido
' Adaptado por : Ángel Gil
' Actualizado : 12/03/2002
' Propósito : Encriptar o desencriptar una cadena de texto enviada como parámetro
' Retorno : String
'---------------------------------------------------------------------------------------
Function CodRot13(CadenaEnviada As String)
Dim strAlfabeto As String
Dim intLongitudCadena As Integer
Dim intContador As Integer
Dim strCaracterBuscar As String
Dim intPosicionCaracter As Integer
Dim strCadenaSalida As String
strAlfabeto = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
intLongitudCadena = Len(CadenaEnviada)
For intContador = 1 To intLongitudCadena
strCaracterBuscar = Mid(CadenaEnviada, intContador, 1)
'---- Posición que ocupa el caracter dentro del abecedario ----'
intPosicionCaracter = InStr(1, strAlfabeto, strCaracterBuscar, 1)
'----Hay que rotar el caracter 13 veces hacia la izquierda-----'
If intPosicionCaracter < 14 Then
intPosicionCaracter = intPosicionCaracter + 13
Else
intPosicionCaracter = intPosicionCaracter - 13
End If
Select Case strCaracterBuscar
Case "A" To "Z"
strCadenaSalida = strCadenaSalida & Mid(strAlfabeto, intPosicionCaracter, 1)
Case "a" To "z"
strCadenaSalida = strCadenaSalida & LCase(Mid(strAlfabeto, intPosicionCaracter, 1))
'La eñe y vocales acentuadas así como los caracteres especiales y números no se codifican
'se dejan “tal cual”
Case Else
strCadenaSalida = strCadenaSalida & strCaracterBuscar
End Select
Next
CodRot13 = strCadenaSalida
End Function
'---------------------------------------------------------------------------------------
Function DecryptText(Fuente As String) As String
Dim strDestino As String
Dim intContador As Integer
Dim intLongFuente As Integer
strDestino = Fuente
intLongFuente = Len(Fuente) + 1
For intContador = 1 To Len(strDestino)
Mid$(strDestino, intLongFuente - intContador, 1) = Chr$((30 + intContador - Asc(Mid$(Fuente, intContador, 1))) And 255)
Next intContador
DecryptText = strDestino
End Function
'---------------------------------------------------------------------------------------
Function EncryptText(Fuente As String) As String
Dim strDestino As String
Dim intContador As Integer
Dim intLongFuente As Integer
strDestino = Fuente
intLongFuente = Len(Fuente) + 1
For intContador = 1 To Len(strDestino)
Mid$(strDestino, intContador, 1) = Chr$((30 + intContador - Asc(Mid(Fuente, intLongFuente - intContador, 1))) And 255)
Next intContador
EncryptText = strDestino
End Function
