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