Queremos llevar un control de quien modifica o Elimina un registro de nuestra base de datos......?????? Option Compare Database Option Explicit '*************************************************************** '& &* '& &* '& &* '& &* '& Jefferson Jimenez (JJJT) &* '& Cabimas - Venezuela &* '& Mayo - 2011 &* '& &* '& &* '& &* '& &* '& &* '*************************************************************** ' _ * ACTIVAR LA REFERENCIA A Microsoft ActiveX Data Objects 2.6 Library * Private cn As New ADODB.Connection Private rst As New ADODB.Recordset Private iField As Long Private i As Long Private obj_Field As ADODB.Field Private cadena As Variant Private CampoCompara As String Private CampoClave As String Private Escribe As String Global Autorizado As Boolean Global QuienEntro As String Public Const RutaTblAuditoria As String = "\Tbl Auditoria\TblAuditoriaInterna.accdb" Public Const TblAuditoria As String = "MiAuditoriaInterna" Public Const TblEliminaron As String = "QueEliminaron" 'DETECTO CAMBIOS EN LOS REGISTROS Y LOS GUARDO A LA TABLA AUDITORIA Sub DetectaCambios(frmForm As Form, RegistroPrincipal As Variant, Cancel As Integer, Optional FormClave As String) Dim Ctl As control Dim TiPo As String Dim StrNuevo As String Dim StrViejo As String Dim Sql As String On Error Resume Next If FormClave = vbNullString Then Autorizado = True If Autorizado Then If Not IsNull(RegistroPrincipal) Then For Each Ctl In frmForm.Controls If TypeOf Ctl Is TextBox Or TypeOf Ctl Is ComboBox _ Or TypeOf Ctl Is CheckBox Or TypeOf Ctl Is OptionButton Then If Ctl.Value <> Ctl.OldValue Or IsNull(Ctl.OldValue) Or IsNull(Ctl.Value) Then If IsNull(Ctl.Value) And Not IsNull(Ctl.OldValue) Or Not IsNull(Ctl.Value) Then DoCmd.TransferDatabase acLink, _ "Microsoft Access", CurrentProject.path & RutaTblAuditoria, _ acTable, TblAuditoria, TblAuditoria, False If Ctl.ControlType = 106 Then: TiPo = "CheckBox - " If Ctl.ControlType = 105 Then: TiPo = "Opcion - " If Ctl.ControlType = 106 Or Ctl.ControlType = 105 Then StrNuevo = Ctl.Value: StrViejo = Ctl.OldValue If StrNuevo = "-1" Then StrNuevo = "Verdadero" If StrViejo = "-1" Then StrViejo = "Verdadero" If StrNuevo = "0" Then: StrNuevo = "Falso" If StrViejo = "0" Then StrViejo = "Falso" End If If Ctl.ControlType = 109 Then: TiPo = "TextBox - ": StrNuevo = Ctl.Value: StrViejo = Ctl.OldValue If Ctl.ControlType = 111 Then: TiPo = "ComboBox - ": StrNuevo = Ctl.Value: StrViejo = Ctl.OldValue DoCmd.SetWarnings False Sql = "INSERT INTO " & TblAuditoria & " " Sql = Sql & "( CodigoCampo,DelFormulario, [TipoCampo Nombre], DatoAnterior, " & _ "NuevoDato,QuienModifico, FechaHora ) " Sql = Sql & " SELECT '" & RegistroPrincipal & "', " Sql = Sql & " '" & frmForm.Name & "', " Sql = Sql & "'" & TiPo & " " & Ctl.Name & "', " Sql = Sql & "'" & StrViejo & "', " Sql = Sql & "'" & StrNuevo & "'," Sql = Sql & "'" & Nz(QuienEntro, "") & "', " Sql = Sql & "'" & Now & "'" DoCmd.RunSQL Sql DoCmd.SetWarnings True End If End If End If Next Ctl End If EliMinaTabLA TblAuditoria Else MsgBox "Se ha perdido la conexion de la BD con el usuario. vuelva a ingresar la clave", vbInformation, "JJJT" frmForm.Undo DoCmd.OpenForm FormClave Cancel = True End If End Sub 'DETECTO LA ELIMINACION EN LOS REGISTROS Y LOS GUARDO A LA TABLA QUEELIMINARON Sub DetectoElimina(frmDelete As Form, CpoClave As String, StrCriteria As String) Dim SqlEscribe As String CampoCompara = StrCriteria CampoClave = CpoClave DoCmd.TransferDatabase acLink, _ "Microsoft Access", CurrentProject.path & RutaTblAuditoria, _ acTable, TblEliminaron, TblEliminaron, False On Error Resume Next cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & CurrentProject.FullName & ";Persist Security Info=False" If IsNumeric(StrCriteria) Then cadena = "SELECT * FROM " & frmDelete.RecordSource & " WHERE " & CampoClave & "=" & CampoCompara & "" Else cadena = "SELECT * FROM " & frmDelete.RecordSource & " WHERE " & CampoClave & "='" & CampoCompara & "'" End If rst.Open cadena, cn, adOpenKeyset, adLockOptimistic iField = rst.Fields.count - 1 rst.MoveFirst Do While Not rst.EOF For i = 0 To iField Set obj_Field = rst.Fields(i) Escribe = Escribe & obj_Field.Name & " = " & obj_Field.Value & vbNewLine Next rst.MoveNext Loop DoCmd.SetWarnings False SqlEscribe = "INSERT INTO " & TblEliminaron & " " SqlEscribe = SqlEscribe & "( Tabla,FechaEliminacion, Responsable, [Campos - Datos]) " SqlEscribe = SqlEscribe & " SELECT '" & frmDelete.RecordSource & "', " SqlEscribe = SqlEscribe & " '" & Format(Date, "dd/mmm/yyyy") & "', " SqlEscribe = SqlEscribe & "'" & QuienEntro & "', " SqlEscribe = SqlEscribe & "'" & Escribe & "'" DoCmd.RunSQL SqlEscribe DoCmd.SetWarnings True rst.Close cn.Close Set obj_Field = Nothing Set rst = Nothing Set cn = Nothing cn.ConnectionString = Null Escribe = "" EliMinaTabLA TblEliminaron End Sub Sub CerrarFrm(Cancel As Integer) If Not rst Is Nothing Then If rst.State = adStateOpen Then rst.Close Set rst = Nothing End If If Not cn Is Nothing Then If cn.State = adStateOpen Then cn.Close Set cn = Nothing End If End Sub Sub EliMinaTabLA _ (StrTaBla As String) Dim Tabla As TableDef Dim MiBase As Database: Set MiBase = CurrentDb For Each Tabla In MiBase.TableDefs If Tabla.Name = StrTaBla Then MiBase.TableDefs.Delete (StrTaBla) Exit For End If Next MiBase.Close Set MiBase = Nothing End Sub 'Y PARA LLAMAR LA FUNCION DESDE CUALQUIER FORMULARIO 'SUPONIENDO ESTE SE LLAME PRODUCTOS Y SU CLAVE_ID SEA IdProductos 'Private Sub Form_BeforeUpdate(Cancel As Integer) 'DetectaCambios Me, Me.IdProductos, Cancel, "Clave" 'Si entramos al soft con clave 'DetectaCambios Me, Me.IdProductos, Cancel 'Si entramos al soft sin clave de usuario 'End Sub 'Private Sub Form_Delete(Cancel As Integer) 'DetectoElimina Me, "IdProductos", Me.IdProductos.Value 'End Sub 'Private Sub Form_Unload(Cancel As Integer) 'CerrarFrm Cancel 'End Sub |
Auditoria Interna (Control Modificar o Eliminar Registros)
Selection | File type icon | File name | Description | Size | Revision | Time | User |
---|---|---|---|---|---|---|---|
ċ
|
Descargar |
Descargue el Ejemplo | 213 kb | v. 1 | 11 jul. 2011 18:59 | Jefferson Jimenez |