** NORMAS DEL FORO **
Inicio del foro Inicio del foro > Access y VBA > Tus Funciones Favoritas & Aportaciones & Artí­culos
  Mensajes nuevos Mensajes nuevos RSS - Encriptar / desencriptar datos tablas
  Preguntas frecuentes Preguntas frecuentes  Buscar en el foro   Eventos   Registro Registro  Iniciar sesion Iniciar sesion

Encriptar / desencriptar datos tablas
 Responder Responder
Autor
Mensaje
  Tema Buscar Tema Buscar  Opciones del Tema Opciones del Tema
pmartimor Ver desplegable
Nuevo
Nuevo
Avatar

Unido: 13/Octubre/2008
Localización: España
Estado: Sin conexión
Puntos: 30 		Opciones de entrada Opciones de entrada   Gracias (0) Gracias(0)   Cita pmartimor Cita  ResponderRespuesta Enlace directo a este mensaje Tema: Encriptar / desencriptar datos tablas
    Enviado: 08/Junio/2023 a las 00:10
Por si a alguien puede ser de utilidad, he realizado este ejercicio para encriptar y desencriptar los registros de una tabla. 
Base de datos comprimida en zip, realizado con Access de Office 2016, y captura imagen en 
Código: En un solo form

Option Compare Database
Option Explicit
Dim Literal As String
Dim sClave1 As String, sClave2 As String, sClave3 As String
Dim s1 As String, s2 As String, s3 As String
Dim db As DAO.Database, rs As DAO.Recordset
Dim sSQL As String
Dim vED As Variant
Dim sClave As String
Dim smiED As String
Dim smiEncriptado As String

'---------------------------------------------------
Private Sub Form_Open(Cancel As Integer)

    Me.txtClave1 = ""
    Me.txtClave2 = ""
    Me.txtClave3 = ""
    s1 = ""
    s2 = ""
    s3 = ""
    Call LeerTablaDED
    If smiEncriptado = "Si" Then
        Call ActivaDesencriptado
        Me.txtClave3.SetFocus
    Else
        Call ActivaEncriptado
        Me.txtClave1.SetFocus
    End If
    
End Sub

'------------------------------------------
Private Sub cmdEncriptar_Click()

    Call LeerTablaDED
    If smiEncriptado = "Si" Then 'no puedo encriptar
        Me.txtClave1 = ""
        Me.txtClave2 = ""
        Call ActivaDesencriptado
        Exit Sub
    Else 'SI puedo encriptar, no puedo desencriptar
        Call ActivaEncriptado
    End If
    
If IsNull(Me.txtClave1) Or Me.txtClave1 = "" Then
    MsgBox "La clave no puede estar vacía."
    s1 = ""
    Me.txtClave1.SetFocus
    Exit Sub
End If
sClave1 = s1
'MsgBox sClave1
If IsNull(Me.txtClave2) Or Me.txtClave2 = "" Then
    MsgBox "Debe de repetir la clave en el cuadro de texto correspondiente."
    s2 = ""
    Me.txtClave2.SetFocus
    Exit Sub
End If
sClave2 = s2
'msgBox sClave2
If sClave1 <> sClave2 Then
    MsgBox "Las claves deben de ser iguales."
    Me.txtClave1 = ""
    Me.txtClave2 = ""
    s1 = ""
    s2 = ""
    Me.txtClave1.SetFocus
    Exit Sub
End If

Call EDTablaDatos(sClave1, 1) 'encriptar o desencriptar tabla Datos, 1 = encriptar, 2 = desencriptar
Call GrabarClave
Me.Refresh

End Sub

'----------------------------------------------------------
Private Sub cmdDesencriptar_Click()

    Call LeerTablaDED
    If smiEncriptado = "No" Then 'no puedo desencriptar
        Call ActivaEncriptado
        Exit Sub
    Else 'SI puedo desencriptar, no puedo encriptar
        Call ActivaDesencriptado
    End If
    
If IsNull(Me.txtClave3) Or Me.txtClave3 = "" Then
    MsgBox "La clave no puede estar vacía."
    s3 = ""
    Me.txtClave3.SetFocus
    Exit Sub
End If
sClave3 = s3

Call ObtenerInformacionPC
Call ED(sClave3, Literal, 1)
If vED = smiED Then 'la clave es válida
    Call EDTablaDatos(sClave3, 2) 'encriptar o desencriptar tabla Datos, 2 = desencriptar
    Call EscribirTablaDEDdensencriptado
    Me.Refresh
Else
    MsgBox "Clave errónea."
    Me.txtClave3 = ""
    s3 = ""
    Me.txtClave3.SetFocus
End If

End Sub

' ---------------------- Encriptar o desencriptar tabla Datos
Private Sub EDTablaDatos(sClave As String, x As Integer)

Set db = CurrentDb()
sSQL = "Select * From Datos"
Set rs = db.OpenRecordset(sSQL, dbOpenDynaset)
Do While Not rs.EOF
    Call ED(sClave, rs!Dtexto, x) 'encripto o desencripto cada registro de la tabla
    rs.Edit
    rs!Dtexto = vED
    rs.Update
    rs.MoveNext
Loop
rs.Close

End Sub

'-------------------------------------------------
Private Sub EscribirTablaDEDdensencriptado()

    Call ObtenerInformacionPC
    Set db = CurrentDb()
    sSQL = "Select * From DED"
    Set rs = db.OpenRecordset(sSQL, dbOpenDynaset)
    rs.MoveFirst
    rs.Edit
    rs!miEd = Literal
    rs!miencriptado = "No"
    rs.Update
    rs.Close
    Call ActivaEncriptado
    
End Sub

'----------------------------------------------------
Private Sub GrabarClave()

    Call ObtenerInformacionPC
    Set db = CurrentDb()
    sSQL = "Select * From DED"
    Call ED(sClave1, Literal, 1)
    Set rs = db.OpenRecordset(sSQL, dbOpenDynaset)
    rs.MoveFirst
    rs.Edit
    rs!miEd = vED
    rs!miencriptado = "Si"
    rs.Update
    rs.Close
    Call ActivaDesencriptado

End Sub

'--------------------------------------------------------
Private Sub LeerTablaDED()
    Set db = CurrentDb()
    sSQL = "Select * From DED"
    Set rs = db.OpenRecordset(sSQL, dbOpenDynaset)
    If rs.RecordCount < 1 Then 'si es la primera vez que abrimos la tabla
        Call ObtenerInformacionPC
        rs.AddNew
        rs!miEd = Literal
        rs!miencriptado = "No"
        rs.Update
    Else 'ya existen datos en la tabla
        rs.MoveFirst
        smiED = rs!miEd
        smiEncriptado = rs!miencriptado
    End If
    rs.Close
End Sub

'-------------------------------------------------------
' Para ampliar el control de pulsación de teclas con KeyDown, puedes visitar la página:
Private Sub txtClave1_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyReturn Or KeyCode = vbKeyTab Then ' Presionar Enter
        KeyCode = 0 ' Desactivar el comportamiento predeterminado de Enter (salto de línea)
        txtClave2.SetFocus ' Enfocar otra caja de texto
    ElseIf KeyCode = vbKeyBack Then ' Retroceso
        Dim textL As Integer
        textL = Len(txtClave1.Text) + 1
        If textL > 0 And Len(s1) > 0 Then 'si hay texto
            txtClave1.Text = Left(txtClave1.Text, textL - 1) ' Borrar el último carácter
            txtClave1.SelStart = Len(txtClave1.Text) ' Posicionar el cursor después del último carácter
            s1 = Left(s1, Len(s1) - 1)
        End If
    Else
        s1 = s1 & Chr(KeyCode) 'guardar el código en el array s1
        KeyCode = vbKeyMultiply 'mostrar un asterisco
    End If
End Sub

'------------------------------------------------------
Private Sub txtClave2_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyReturn Or KeyCode = vbKeyTab Then ' Presionar Enter
        KeyCode = 0 ' Desactivar el comportamiento predeterminado de Enter (salto de línea)
        Me.cmdEncriptar.SetFocus ' Enfocar otra caja de texto
    ElseIf KeyCode = vbKeyBack Then ' Retroceso
        Dim textL As Integer
        textL = Len(txtClave2.Text) + 1
        If textL > 0 And Len(s2) > 0 Then 'si hay texto
            txtClave2.Text = Left(txtClave2.Text, textL - 1) ' Borrar el último carácter
            txtClave2.SelStart = Len(txtClave2.Text) ' Posicionar el cursor después del último carácter
            s2 = Left(s2, Len(s2) - 1)
        End If
    Else
        s2 = s2 & Chr(KeyCode)
        KeyCode = vbKeyMultiply
    End If
End Sub

'---------------------------------------------------------
Private Sub txtClave3_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyReturn Or KeyCode = vbKeyTab Then ' Presionar Enter
        KeyCode = 0 ' Desactivar el comportamiento predeterminado de Enter (salto de línea)
        Me.cmdDesencriptar.SetFocus ' Enfocar otra caja de texto
    ElseIf KeyCode = vbKeyBack Then ' Retroceso
        Dim textL As Integer
        textL = Len(txtClave3.Text) + 1
        If textL > 0 And Len(s3) > 0 Then 'si hay texto
            txtClave3.Text = Left(txtClave3.Text, textL - 1) ' Borrar el último carácter
            txtClave3.SelStart = Len(txtClave3.Text) ' Posicionar el cursor después del último carácter
            s3 = Left(s3, Len(s3) - 1)
        End If
    Else
        s3 = s3 & Chr(KeyCode)
        KeyCode = vbKeyMultiply
    End If
End Sub

'-----------------------------------------------------
Sub ObtenerInformacionPC()
    Dim nombrePC As String
    Dim fs, d
    'Obtener el nombre del PC
    nombrePC = Environ("COMPUTERNAME")
    'Obtener numero serie disco
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set d = fs.GetDrive(fs.GetDriveName(fs.GetAbsolutePathName("C")))
    Literal = nombrePC & d.SerialNumber
End Sub

'------------------------------------------------
Private Sub ActivaEncriptado()
    Me.cmdEncriptar.Enabled = True
    Me.txtClave1.Enabled = True
    Me.txtClave2.Enabled = True
    Me.cmdDesencriptar.Enabled = False
    Me.txtClave3.Enabled = False
    Me.txtClave3 = ""
    s3 = ""
End Sub

'-------------------------------------------------
Private Sub ActivaDesencriptado()
    Me.cmdEncriptar.Enabled = False
    Me.cmdDesencriptar.Enabled = True
    Me.txtClave1.Enabled = False
    Me.txtClave2.Enabled = False
    Me.txtClave3.Enabled = True
    Me.txtClave1 = ""
    Me.txtClave2 = ""
    s1 = ""
    s2 = ""
End Sub

'-------------------------------------------------
Private Sub ED(sClave As String, sCadena As String, iED As Integer)
' sClave = cadena de caracteres de la clave
' sCadena = cadena de caracteres a encriptar/desencriptar
' iED = 1 -> encriptar, iED=2 -> desencriptar

If sClave = "" Or sCadena = "" Then
    MsgBox ("La clave está vacía.")
    Exit Sub
End If

Dim lCadena As Long 'longitud del string a encriptar / desencriptar
Dim lClave As Long 'longitud de la cadena de la clave
lCadena = Len(sCadena)
lClave = Len(sClave)

Dim aCadena() As Long 'array de la cadena de caracteres a encriptar / desencriptar
Dim aClave() As Long 'array de caracteres de la clave

ReDim aCadena(1 To lCadena)
ReDim aClave(1 To lCadena)

Dim i As Long
' si la clave es menor que la cadena, repito la clave hasta completar la cadena
If lClave < lCadena Then
    For i = 1 To lCadena
        aCadena(i) = Asc(Mid(sCadena, i, 1))
        aClave(i) = Asc(Mid(sClave, ((i - 1) Mod lClave) + 1, 1))
    Next i
Else ' si la clave es mayor que la cadena tomo el num. de caracteres de la clave para el array
    For i = 1 To lCadena
        aCadena(i) = Asc(Mid(sCadena, i, 1))
        aClave(i) = Asc(Mid(sClave, i, 1))
    Next i
End If

vED = ""
' si es encriptar
If iED = 1 Then
    For i = 1 To lCadena
        If (aCadena(i) + aClave(i)) > 255 Then ' si es mayor la suma que 255, resto 255
            vED = vED & Chr((aCadena(i) + aClave(i)) - 255)
        Else ' si es menor la suma no resto
            vED = vED & Chr((aCadena(i) + aClave(i)))
        End If
    Next i
ElseIf iED = 2 Then ' si es desencriptar
    For i = 1 To lCadena
        If (aCadena(i) - aClave(i)) < 0 Then 'resto el ascii de la clave al ascii de la cadena
                                             'y se sumo 255
            vED = vED & Chr((aCadena(i) - aClave(i)) + 255)
        Else 'si es mayor que cero los resto sin sumarle nada
            vED = vED & Chr((aCadena(i) - aClave(i)))
        End If
    Next i
End If

End Sub
'------------------------------- FIN -----------------------



Se puede cerrar el hilo🧵


Editado por pmartimor - 14/Junio/2023 a las 18:38
A veces lo barato es caro.
Arriba
 Responder Responder
  Compartir tema   

Ir al foro Permisos de foro Ver desplegable