.
Ciao @Alex, ti invio il codice originale per la produzione del log.
Questo è il mudulo basForms dove c'è la function OpenFormEX da usare al posto del comando Domcd.OpenForm
Option Compare Database
Option Explicit
Private mcolForms As Collection
-------------------------------
Public Function OpenFormEX(FormName, Optional View As AcFormView = acNormal, _
Optional FilterName As String, Optional WhereCondition As String, _
Optional DataMode As AcFormOpenDataMode = acFormPropertySettings, _
Optional WindowMode As AcWindowMode = acWindowNormal, Optional OpenArgs)
On Error GoTo Proc_Err
Dim rs As DAO.Recordset
DoCmd.OpenForm FormName, View, FilterName, WhereCondition, DataMode, WindowMode, OpenArgs
DoEvents
Set rs = DBEngine(0)(0).OpenRecordset("SELECT * FROM [_EFORMSEVENTS] WHERE TraceON=True AND NomeMaschera='" & FormName & "'", dbOpenDynaset, dbReadOnly)
If Not rs.EOF Then
If CurrentProject.AllForms(FormName).IsLoaded Then
Call AddEventsHandler(Forms(FormName))
End If
End If
Exit_Here:
On Error Resume Next
rs.Close
Set rs = Nothing
Exit Function
Proc_Err:
MsgBox Err.Number & Err.Description
Resume Exit_Here
End Function
-------------------------------
Public Function AddEventsHandler(frmIn As Access.Form) As clsForm
On Error GoTo Proc_Err
Dim curForm As clsForm
Dim strKEY As String
Dim mTraceBeforeUpdate As Boolean
Dim mTraceBeforeInsert As Boolean
Dim mTraceBeforeDelConfirm As Boolean
Dim mTraceError As Boolean
If mcolForms Is Nothing Then
Set mcolForms = New Collection
End If
strKEY = CStr(CollectionCount()) & "_" & frmIn.Name
If Not FormExists(strKEY) Then
Set curForm = New clsForm
Set curForm.Form = frmIn
curForm.Key = strKEY
mcolForms.Add curForm, strKEY
Else
Set curForm = mcolForms(strKEY)
End If
Set AddEventsHandler = curForm
Exit_Here:
Exit Function
Proc_Err:
MsgBox Err.Number & Err.Description
Resume Exit_Here
End Function
-------------------------------
Public Function Item(strKEY As String) As clsForm
On Error GoTo Proc_Err
If FormExists(strKEY) Then
Set Item = mcolForms.Item(strKEY)
End If
Proc_Exit:
Exit Function
Proc_Err:
Item = Nothing
End Function
-------------------------------
Public Sub RemoveForm(strKEY As String)
On Error Resume Next
If FormExists(strKEY) Then
mcolForms.Remove strKEY
End If
End Sub
-------------------------------
Public Function CollectionCount() As Long
If mcolForms Is Nothing Then
CollectionCount = 0
Else
CollectionCount = mcolForms.Count
End If
End Function
-------------------------------
Public Function FormExists(strKEY As String) As Boolean
On Error Resume Next
Dim strValue As String
strValue = mcolForms.Item(strKEY).Key
FormExists = (Err.Number = 0)
Err.Clear
End Function
-------------------------------
Function CollectionItems() As Collection
Set CollectionItems = mcolForms
End Function
Questo è il modulo di classe clsForm dove vengono intercettati gli eventi e prodotte le stringhe dati da passare al modulo successivo basLog e per alcuni eventi attraverso le function FillDataChanged e FillActiveData:
Option Compare Database
Option Explicit
Private mstrKey As String
Private WithEvents mfrm As Access.Form
Private mOnUnloadTrace As Boolean
-------------------------------
Public Property Get Key() As String
Key = mstrKey
End Property
-------------------------------
Public Property Let Key(Key As String)
mstrKey = Key
End Property
-------------------------------
Public Property Set Form(frmIn As Access.Form)
On Error GoTo Err_Events
Dim rs As DAO.Recordset
Set mfrm = frmIn
Dim ctl As Access.Control
For Each ctl In mfrm.Controls
If ctl.ControlType = acSubform Then Call AddEventsHandler(ctl.Form)
Next
Set rs = DBEngine(0)(0).OpenRecordset("SELECT * FROM [_EFORMSEVENTS] WHERE TraceON=True AND NomeMaschera='" & frmIn.Name & "' ORDER BY Evento", dbOpenDynaset, dbReadOnly)
Do Until rs.EOF
Select Case rs.Fields("Evento").Value
Case Is = "AfterDelCofirm"
mfrm.AfterDelConfirm = "[Event Procedure]"
Case Is = "AfterInsert"
mfrm.AfterInsert = "[Event Procedure]"
Case Is = "AfterUpdate"
mfrm.AfterUpdate = "[Event Procedure]"
Case Is = "BeforeDelConfirm"
mfrm.BeforeDelConfirm = "[Event Procedure]"
Case Is = "BeforeInsert"
mfrm.BeforeInsert = "[Event Procedure]"
Case Is = "BeforeUpdate"
mfrm.BeforeUpdate = "[Event Procedure]"
Case Is = "OnActivate"
mfrm.OnActivate = "[Event Procedure]"
Case Is = "OnCurrent"
mfrm.OnCurrent = "[Event Procedure]"
Case Is = "OnDeactivate"
mfrm.OnDeactivate = "[Event Procedure]"
Case Is = "OnError"
mfrm.OnError = "[Event Procedure]"
Case Is = "OnLoad"
' L'Evento LOAD si è già Verificato all'istanza, quindi
' genero l'EventLOG in questo modo.
Call EventLog(mfrm.Name, "Load", "ON")
Case Is = "OnUnload"
mOnUnloadTrace = True
End Select
rs.MoveNext
Loop
If IsSubForm(mfrm) = False Then mfrm.OnUnload = "[Event Procedure]"
Exit_Here:
On Error Resume Next
rs.Close
Set rs = Nothing
Exit Property
Err_Events:
MsgBox Err.Number & " - " & Err.Description
Resume Exit_Here
End Property
-------------------------------
Private Sub mfrm_Activate()
Call EventLog(mfrm.Name, "Activate", "ON")
End Sub
-------------------------------
Private Sub mfrm_AfterDelConfirm(Status As Integer)
Dim strStatus As String
Select Case Status
Case Is = acDeleteOK
strStatus = "Record CANCELLATO"
Case Is = acDeleteCancel
strStatus = "Evento Annullato da VBA"
Case Is = acDeleteUserCancel
strStatus = "Evento Annullato dall'Utente"
End Select
Call EventLog(mfrm.Name, "AfterDelConfirm", strStatus)
End Sub
-------------------------------
Private Sub mfrm_AfterInsert()
Call EventLog(mfrm.Name, "AfterInsert", FillActiveData())
End Sub
Private Sub mfrm_AfterUpdate()
Dim strUPD As String
strUPD = FillActiveData()
Call EventLog(mfrm.Name, "AfterUpdate", strUPD)
End Sub
-------------------------------
Private Sub mfrm_BeforeDelConfirm(Cancel As Integer, Response As Integer)
Dim strUPD As String
Response = acDataErrContinue
' Display custom dialog box.
If MsgBox("Cancello questo record ?", vbOKCancel) = vbCancel Then
Cancel = True
Else
strUPD = FillActiveData()
' LOG
Call EventLog(mfrm.Name, "BeforeDelConfirm", strUPD)
End If
End Sub
-------------------------------
Private Sub mfrm_BeforeInsert(Cancel As Integer)
Dim strUPD As String
strUPD = FillActiveData()
' LOG
Call EventLog(mfrm.Name, "BeforeInsert", strUPD)
End Sub
-------------------------------
Private Sub mfrm_BeforeUpdate(Cancel As Integer)
Dim strUPD As String
strUPD = FillDataChanged()
' LOG
Call EventLog(mfrm.Name, "BeforeUpdate", strUPD)
End Sub
-------------------------------
Private Sub mfrm_Current()
Dim strUPD As String
strUPD = FillActiveData()
Call EventLog(mfrm.Name, "Current", strUPD)
End Sub
-------------------------------
Private Sub mfrm_Deactivate()
Call EventLog(mfrm.Name, "Deactivate", "OFF")
End Sub
-------------------------------
Private Sub mfrm_Error(DataErr As Integer, Response As Integer)
Dim strChange As String
strChange = FillDataChanged()
' LOG
Call EventLog(mfrm.Name, "ERROR", "ERR=" & DataErr & " " & Application.AccessError(DataErr) & " - " & strChange)
End Sub
-------------------------------
Private Sub mfrm_Unload(Cancel As Integer)
If mOnUnloadTrace Then Call EventLog(mfrm.Name, "Unload", "ON")
Call RemoveForm(Me.Key)
End Sub
-------------------------------
Private Function FillDataChanged() As String
On Error GoTo Err_Fill
Dim ctl As Access.Control
Dim idx As Integer
Dim strData As String
FillDataChanged = vbNullString
For Each ctl In mfrm.Controls
If ctl.ControlType <> acImage And ctl.ControlType <> acSubform And ctl.ControlType <> acBoundObjectFrame Then
If HasProperty(ctl, "ControlSource") Then
If Len(ctl.ControlSource) > 0 And Not ctl.ControlSource Like "=*" Then
If ctl.Value <> ctl.OldValue Then
strData = strData & "[" & ctl.Name & "] --> (OldVal=" & ctl.OldValue & ") - (NewVal=" & ctl.Value & ") ##"
End If
End If
End If
End If
Next
If Len(strData) > 0 Then strData = Mid$(strData, 1, Len(strData) - 3)
FillDataChanged = strData
Exit_Here:
Exit Function
Err_Fill:
FillDataChanged = vbNullString
Resume Exit_Here
End Function
-------------------------------
Private Function FillActiveData() As String
On Error GoTo Err_Del
Dim ctl As Access.Control
Dim idx As Integer
Dim strData As String
FillActiveData = vbNullString
For Each ctl In mfrm.Controls
If ctl.ControlType <> acImage And ctl.ControlType <> acSubform And ctl.ControlType <> acBoundObjectFrame Then
If HasProperty(ctl, "ControlSource") Then
If Len(ctl.ControlSource) > 0 And Not ctl.ControlSource Like "=*" Then
strData = strData & "[" & ctl.Name & " = " & ctl.Value & "] ## "
Debug.Print strData
End If
End If
End If
Next
If Len(strData) > 0 Then strData = Mid$(strData, 1, Len(strData) - 4)
FillActiveData = strData
Exit_Here:
Exit Function
Err_Del:
FillActiveData = vbNullString
Resume Exit_Here
End Function
-------------------------------
Private Function HasProperty(obj As Object, strPropName As String) As Boolean
'Purpose: Return true if the object has the property.
Dim varDummy As Variant
On Error Resume Next
varDummy = obj.Properties(strPropName)
HasProperty = (Err.Number = 0)
End Function
-------------------------------
Private Function IsSubForm(frm As Form) As Boolean
' =====================================================
' Verifica se la Form è caricata come SubForm
' cercando la proprietà Name della Form.Parent
' ed intercettando l'errore.
' In:
' frm: Form da verificare
' Out:
' Return value: True se è Subform
' False se è Principale
' =====================================================
On Error Resume Next
Dim strName As String
strName = frm.Parent.Name
IsSubForm = (Err.Number = 0)
Err.Clear
End Function
Questo è basLog, il terzo e ultimo modulo, dove vengono creati e popolati i file di log.
Option Compare Database
Option Explicit
-------------------------------
Function EventLog(ByVal FormName As String, _
ByVal EventAction As String, _
strDataChange As String) As Boolean
On Error GoTo Err_LOG
Dim intFile As Integer
Dim strPathFile As String
Dim strMsgOut As String
Dim strHeader As String
Const cDelimiter As String = vbTab
EventLog = False
If FolderExists(CurrentProject.path & "\EventLog") = False Then MkDir CurrentProject.path & "\EventLog"
strPathFile = CurrentProject.path & "\EventLog\Event_" & Format(Now(), "ddmmyyyy") & ".txt"
intFile = FreeFile
strMsgOut = Format(Now(), "dd/mm/yyyy hh:mm:ss")
If Len(CurrentUser()) > 0 Then strMsgOut = strMsgOut & cDelimiter & CurrentUser()
If Len(FormName & "") > 0 Then strMsgOut = strMsgOut & cDelimiter & FormName
If Len(EventAction) > 0 Then strMsgOut = strMsgOut & cDelimiter & EventAction
If Len(strDataChange) > 0 Then strMsgOut = strMsgOut & cDelimiter & strDataChange
strHeader = vbNullString
If FileExists(strPathFile) = False Then
strHeader = "DATA" & cDelimiter & "USER" & cDelimiter & "MASCHERA" & cDelimiter & "AZIONE" & cDelimiter & "DATI"
End If
Open strPathFile For Append Shared As #intFile
If Len(strHeader) > 0 Then Print #intFile, strHeader
Print #intFile, strMsgOut
Close #intFile
EventLog = True
Exit_Here:
Exit Function
Err_LOG:
MsgBox "Errore non previsto. Impossibile accodare al LOG ERROR" & vbNewLine & " Visualizza CTRL+G"
Resume Exit_Here
End Function
-------------------------------
Public Function FileExists(ByVal str As String) As Boolean
On Error Resume Next
FileExists = (GetAttr(str) And vbDirectory) = 0
End Function
-------------------------------
Function FolderExists(strPath As String) As Boolean
On Error Resume Next
FolderExists = ((GetAttr(strPath) And vbDirectory) = vbDirectory)
End Function
Aspetto notizie.
Grazie.
Alex66