Password para informe de Access
Tengo un botón que lanza un informe confidencial, ¿sabéis si hay algún modo de que antes de lanzar el informe (vista previa) pida un password?
Juan Pedro, tendrías que convertir la base a accde. Ten en cuenta que si tiene algún conocimiento de Access podría localizar el código y cambiarlo. Al convertir una base a accde, lo que hace es encriptar el código y no te deja ver el diseño de los formularios e informes.
Dicho esto, en vista diseño del informe puedes poner, por dar una idea, ya que lo puedes hacer de muchas formas
Private Sub Report_Open(Cancel As Integer)
Dim s As String
s = InputBox("Introduzca la contraseña", "Procura acertar o tendré que...")
If s <> "Juan" Then
Cancel = True
DoCmd.Close
End If
End Sub
Si no acierta con la clave Juan, el informe no llega a abrirse. Si lo que quieres es que al no acertar con la contraseña, del medio de la pantalla le salga un láser que lo deje ciego y le perfore el cráneo, es un poco más difícil.
2 respuestas más de otros expertos
Juan Pedro, hay muchas formas de asegurar la información, pero he preparado este ejemplo tratando de conservar su pregunta.
Utilizo una tabla para registrar los reportes:
Formulario para registrar los reportes y la contraseña
Código del botón Crear
Private Sub btnCrear_Click()
On Error GoTo hay_error
Dim strCry As String
Dim strSQL As String
If IsNull(Me.ctlReporte) Then
Exit Sub
End If
If IsNull(Me.ctlpass1) Or IsNull(Me.ctlpass2) Then
Exit Sub
End If
If Me.ctlpass1.Value <> Me.ctlpass2.Value Then
MsgBox "Verifique el password", vbInformation, "Cuidado"
Else
strCry = Crypt(Me.ctlpass1, Me.ctlpass1)
strSQL = "'" & Me.ctlReporte & "','" & strCry & "','" & Me.ctlpass1 & "'"
CurrentDb.Execute "INSERT INTO tblPasswordRpt(Reporte,Encrypta,Password) VALUES(" & strSQL & ")"
End If
If Err.Number = 0 Then
MsgBox "Password registrado OK", vbInformation, "Le informo"
End If
hay_error_Exit:
Exit Sub
hay_error:
MsgBox "Ocurrió el error " & Err.Number & vbCrLf & Err.Description, vbCritical, "Error.."
Resume hay_error_Exit
End SubObserve que utilizo la función Cryp() para encriptar la contraseña.
Adicione este módulo
'Clave de encriptación: oscar2021
'Ejemplo:Crypt("10052021001000520351","oscar2021")
'Retorna: BA8034C484B1B364C7CE6B2802C008FA02DCCAB3
'
'Ejempo desencripta: decrypt("BA8034C484B1B364C7CE6B2802C008FA02DCCAB3","oscar2021")
'Retorna; 10052021001000520351
'
Public Function Crypt(ByVal sValue As String, sKey As String) As String
On Error GoTo error
Crypt = ToHexDump(CryptRC4(sValue, sKey))
Exit Function
error:
Crypt = sValue
Debug.Print Err.Description
End Function
Public Function DeCrypt(ByVal sValue As String, sKey As String) As String
On Error GoTo error
DeCrypt = CryptRC4(FromHexDump(sValue), sKey)
Exit Function
error:
DeCrypt = sValue
Debug.Print Err.Description
End Function
Private Function CryptRC4(sText As String, sKey As String) As String
Dim baS(0 To 255) As Byte
Dim baK(0 To 255) As Byte
Dim bytSwap As Byte
Dim lI As Long
Dim lJ As Long
Dim lIdx As Long
For lIdx = 0 To 255
baS(lIdx) = lIdx
baK(lIdx) = Asc(Mid$(sKey, 1 + (lIdx Mod Len(sKey)), 1))
Next
For lI = 0 To 255
lJ = (lJ + baS(lI) + baK(lI)) Mod 256
bytSwap = baS(lI)
baS(lI) = baS(lJ)
baS(lJ) = bytSwap
Next
lI = 0
lJ = 0
For lIdx = 1 To Len(sText)
lI = (lI + 1) Mod 256
lJ = (lJ + baS(lI)) Mod 256
bytSwap = baS(lI)
baS(lI) = baS(lJ)
baS(lJ) = bytSwap
CryptRC4 = CryptRC4 & Chr$((pvCryptXor(baS((CLng(baS(lI)) + baS(lJ)) Mod 256), Asc(Mid$(sText, lIdx, 1)))))
Next
End Function
Private Function pvCryptXor(ByVal lI As Long, ByVal lJ As Long) As Long
If lI = lJ Then
pvCryptXor = lJ
Else
pvCryptXor = lI Xor lJ
End If
End Function
Private Function ToHexDump(sText As String) As String
Dim lIdx As Long
For lIdx = 1 To Len(sText)
ToHexDump = ToHexDump & Right$("0" & Hex(Asc(Mid(sText, lIdx, 1))), 2)
Next
End Function
Private Function FromHexDump(sText As String) As String
Dim lIdx As Long
For lIdx = 1 To Len(sText) Step 2
FromHexDump = FromHexDump & Chr$(CLng("&H" & Mid(sText, lIdx, 2)))
Next
End FunctionAl Abrir el reporte obtengo:
Observe los asteriscos, para obtener estos en una función inputbox se debe utilizo una función del maestro Juan M. Afan de Ribera (mis respetos). No la voy a incluir acá, pero puede comentar la línea donde la llamo el inputBoxEx y activar la del inputbox. La función inputBoxEx permite pasar el parámetro Spassword para incluir los asteriscos.
Función para abrir el inputbox
Public Function permiso_rpt(miRpt As String) As Boolean
Dim strEncrypta As String
Dim strPassword As String
Dim strPass As String
Dim strDecrypta As String
strEncrypta = DLookup("Encrypta", "tblPasswordRpt", "Reporte='" & miRpt & "'")
strPassword = DLookup("Password", "tblPasswordRpt", "Reporte='" & miRpt & "'")
regrese:
'strPass = InputBox("Password : ", "Permiso Reporte", "*")
strPass = InputBoxEx("Password : ", "Permiso Reporte", , , , , , SPassword, 20)
If strPass = "" Then
permiso_rpt = False
Exit Function
End If
If strPass <> strPassword Then
MsgBox "Verifique el password", vbInformation, "Cuidado"
GoTo regrese
End If
strDecrypta = DeCrypt(strEncrypta, strPass)
If strDecrypta <> strPassword Then
MsgBox "No tiene permiso", vbInformation, "Le informo"
permiso_rpt = False
Else
permiso_rpt = True
End If
End FunctionLlamando la función desde el evento Al abrir de los reportes
Private Sub Report_Open(Cancel As Integer) If permiso_rpt(Me.Report.Name) = False Then Cancel = True End If End Sub
Bueno esto es una idea, pero hay muchas formas
Si hay datos confidenciales, lo primero es asegurar la base de datos, de forma que solo puedan acceder los que tengan autorización y el resto (según se asegure) puede que ni puedan ver/acceder al informe (y menos a sus datos de origen).
Si no se la asegura un método (sencillo) es crear una copia de la base para 'usuarios no y autorizados' en ella borrar los formularios e informes confidenciales y dejarla para uso general (la copia completa solo para los 'autorizados').