Code to log usage of forms and reports

Option Compare Database
Option Explicit

'Purpose:       Log when your forms/reports are opened/closed.
'Author:        Allen Browne
'Usage:         Open/close events of forms/reports call LogDocOpen() and LogDocClose()
'Documentation: http://allenbrowne.com/AppLogDocUse.html

'Set this to False to turn all logging off.
Private Const mbLogDox As Boolean = True
'Name of this module (for error logger.)
Private Const conMod = "ajbLogDoc"

'API calls to get the Windows user name and computer name
Private Declare Function apiGetUserName Lib "advapi32.dll" _
    Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function apiGetComputerName Lib "kernel32" _
    Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
    
Public Function LogDocOpen(obj As Object) As Long
On Error GoTo Err_Handler
    'Purpose:   Create a log entry for the form/report being opened.
    'Argument:  The form or report whose opening we are logging.
    'Return:    Primary key value of the log entry. Zero on error.
    'Usage:     For a form, set the On Open property to:    =LogDocOpen([Form])
    '           For a report, set the On Open property to:  =LogDocOpen([Report])
    Dim rs As DAO.Recordset
    Dim lngObjType As Long          'acForm or acReport
    Dim strDoc As String            'Name of the form/report
    Dim lngHWnd As String           'hWnd of the form/report
    
    If mbLogDox Then
        strDoc = obj.Name
        lngHWnd = obj.Hwnd
        
        Set rs = DBEngine(0)(0).OpenRecordset("tblLogDoc", dbOpenDynaset, dbAppendOnly)
        rs.AddNew
            rs!OpenDateTime = Now()
            rs!CloseDateTime = Null
            rs!DocTypeID = DocType(obj)
            rs!DocName = strDoc
            rs!DocHWnd = lngHWnd
            rs!ComputerName = ComputerName()
            rs!WinUser = NetworkUserName()
            rs!JetUser = CurrentUser()
            rs!CurView = CurView(obj)
        rs.Update
        rs.Bookmark = rs.LastModified
        LogDocOpen = rs!LogDocID
        rs.Close
    End If
    
Exit_Handler:
    Set rs = Nothing
    Exit Function

Err_Handler:
    Call LogError(Err.Number, Err.Description, conMod & ".LogDocOpen", "Document " & strDoc, False)
    Resume Exit_Handler
End Function

Public Function LogDocClose(obj As Object) As Long
On Error GoTo Err_Handler
    'Purpose:   Update the log entry created when the form/report was opened, to mark it closed.
    '           Creates a new entry if the existing one cannot be found.
    'Argument:  The form or report whose closing we are logging.
    'Return:    Primary key value of the log entry updated/created. Zero on error.
    'Usage:     For a form, set the On Close property to:   =LogDocClose([Form])
    '           For a report, set the On Close property to: =LogDocClose([Report])
    Dim rs As DAO.Recordset
    Dim strSql As String            'SQL statement
    Dim strDoc As String            'Name of the form/report
    Dim strWinUser As String        'Name of the Windows user
    Dim strJetUser As String        'Name of the JET engine user
    Dim strComputer As String       'Name of this workstation
    Dim lngObjType As Long          'acForm or acReport
    Dim lngHWnd As String           'hWnd of the form/report
    
    If mbLogDox Then
        strDoc = obj.Name
        strWinUser = NetworkUserName()
        strComputer = ComputerName()
        lngHWnd = obj.Hwnd
        lngObjType = DocType(obj)
        
        'Get the log entry when this user on this computer opened this form/report (same name, type and hWnd)
        strSql = "SELECT tblLogDoc.* FROM tblLogDoc WHERE ((tblLogDoc.DocTypeID = " & lngObjType & ") AND (tblLogDoc.DocName = """ & strDoc & _
            """) AND (tblLogDoc.DocHWnd = " & lngHWnd & ") AND (tblLogDoc.ComputerName = """ & strComputer & """) AND (tblLogDoc.WinUser = """ & strWinUser & _
            """) AND (tblLogDoc.CloseDateTime Is Null) AND (tblLogDoc.OpenDateTime <= Now())) ORDER BY tblLogDoc.OpenDateTime, tblLogDoc.LogDocID;"
        Set rs = DBEngine(0)(0).OpenRecordset(strSql)
        If rs.RecordCount > 0& Then
            'Log entry found: update as closed.
            rs.Edit
                rs!CloseDateTime = Now()
            rs.Update
        Else
            'Can't find when document was opened: create a new one.
            rs.AddNew
                rs!OpenDateTime = Null
                rs!CloseDateTime = Now()
                rs!DocTypeID = lngObjType
                rs!DocName = strDoc
                rs!DocHWnd = lngHWnd
                rs!ComputerName = strComputer
                rs!WinUser = strWinUser
                rs!JetUser = CurrentUser()
                rs!CurView = CurView(obj)
            rs.Update
        End If
        rs.Bookmark = rs.LastModified
        LogDocClose = rs!LogDocID
        rs.Close
    End If
    
Exit_Handler:
    Set rs = Nothing
    Exit Function

Err_Handler:
    Call LogError(Err.Number, Err.Description, conMod & ".LogDocClose", "Document " & strDoc, False)
    Resume Exit_Handler
End Function

Private Function DocType(obj As Object) As Long
On Error GoTo Err_Handler
    'Purpose:   Return the acObjectType for the obj.
    'Argument:  The form/report to examine.
    'Return:    acForm or acReport. Zero on error.
    
    If TypeOf obj Is Form Then
        DocType = acForm
    ElseIf TypeOf obj Is Report Then
        DocType = acReport
    End If

Exit_Handler:
    Exit Function

Err_Handler:
    Call LogError(Err.Number, Err.Description, conMod & ".DocType")
    Resume Exit_Handler
End Function

Private Function CurView(obj As Object) As Variant
    'Purpose:   Return the CurrentView property of the form/report.
    'Return:    An integer represeting the CurrentView. Null on error.
    'Note:      CurrentView errors for reports earlier than Access 2007.
    
    On Error Resume Next
    CurView = obj.CurrentView
    If Err.Number <> 0& Then CurView = Null
End Function

Private Function NetworkUserName() As String
On Error GoTo Err_Handler
    'Purpose:   Returns the network login name.
    Dim lngLen As Long          'Length of string.
    Dim strUserName As String
    Const lngcMaxFieldSize As Long = 64& 'Length of field to store this data.
    
    'Initialize
    strUserName = String$(254, vbNullChar)
    lngLen = 255&
    
    'API returns a non-zero value if success.
    If apiGetUserName(strUserName, lngLen) <> 0& Then
        lngLen = lngLen - 1&    'Without null termination char.
        If lngLen > lngcMaxFieldSize Then  'Maximum field size
            lngLen = lngcMaxFieldSize
        End If
        NetworkUserName = Left$(strUserName, lngLen)
    End If

Exit_Handler:
    Exit Function

Err_Handler:
    Call LogError(Err.Number, Err.Description, conMod & ".NetworkUserName", , False)
    Resume Exit_Handler
End Function

Private Function ComputerName() As String
On Error GoTo Err_Handler
    'Purpose:   Return the name of this workstation.
    Dim strName As String
    Dim lngLen As Long
    
    lngLen = 16&
    strName = String$(lngLen, vbNullChar)
    
    If apiGetComputerName(strName, lngLen) = 0& Then
        ComputerName = "Unknown"
    Else
        ComputerName = Left$(strName, lngLen)
    End If

Exit_Handler:
    Exit Function

Err_Handler:
    Call LogError(Err.Number, Err.Description, conMod & ".fOSMachineName")
    Resume Exit_Handler
End Function

Private Function LogError(ByVal lngErrNumber As Long, _
    ByVal strErrDescription As String, _
    strCallingProc As String, _
    Optional vParameters As Variant, _
    Optional bShowUser As Boolean = True) As Boolean
    'Purpose:   Substitute for the real error logging routine at:
    '           http://allenbrowne.com/ser-23a.html
    
    'If bShowUser Then
        MsgBox "Error " & lngErrNumber & ": " & strErrDescription, vbExclamation, strCallingProc
    'End If
End Function