Results 1 to 2 of 2
  1. #1
    pmartimor is offline Novice
    Windows 10 Access 2016
    Join Date
    Jun 2023
    Posts
    1

    Encriptado simétrico tablas access

    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
    https://drive.google.com/drive/folde...Db?usp=sharing
    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:
    ' https://learn.microsoft.com/es-es/of...code-constants
    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 -----------------------

  2. #2
    Join Date
    Jan 2017
    Location
    Swansea,South Wales,UK
    Posts
    4,858
    Non comprende. Lo siento.

    Might want to use code tags when you post code, especially as large as that lot.
    Use the # button and pasted in between the tags.
    Please use # icon on toolbar when posting code snippets.
    Cross Posting: https://www.excelguru.ca/content.php?184
    Debugging Access: https://www.youtube.com/results?sear...bug+access+vba

Please reply to this thread with any new information or opinions.

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  
Other Forums: Microsoft Office Forums