Auditoria Interna (Control Modificar o Eliminar Registros)

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

SelectionFile type iconFile nameDescriptionSizeRevisionTimeUser
ċ
Descargar		 Descargue el Ejemplo  213 kb v. 1 11 jul. 2011 18:59 Jefferson Jimenez
Comments