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

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

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

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