Cita de jgarcialian-user en 15 de junio de 2023, 23:16

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/folders/194VKAGQ3qoVjynatxwgnsGecWyLOnGDb?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/office/vba/language/reference/user-interface-help/keycode-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 -----------------------