ACC2000: How to Create Your Own Custom Security Reports

The Database Documenter does not enable you to view a report on a per user basis nor to have a report that is grouped by users and groups display the permissions for the objects in your database. However, you can create your own custom reports that display security information. You can do this by using Data Access Objects (DAO) to read and store the permission information.

This article shows you how to store user permissions to objects by using Visual Basic for Applications.

Microsoft provides programming examples for illustration only, without warranty either expressed or implied. This includes, but is not limited to, the implied warranties of merchantability or fitness for a particular purpose. This article assumes that you are familiar with the programming language that is being demonstrated and with the tools that are used to create and to debug procedures. Microsoft support engineers can help explain the functionality of a particular procedure, but they will not modify these examples to provide added functionality or construct procedures to meet your specific requirements. CAUTION: If you follow the steps in this example, you modify the sample database Northwind.mdb. You may want to back up the Northwind.mdb file and follow these steps on a copy of the database.

NOTE: The sample code in this article uses Microsoft Data Access Objects. For this code to run properly, you must reference the Microsoft DAO 3.6 Object Library. To do so, click References on the Tools menu in the Visual Basic Editor, and make sure that the Microsoft DAO 3.6 Object Library check box is selected.

To create your own custom security reports, you must first create the tables, and then create the query that will be used as the record source for the report.

Creating the Tables

To create the tables, follow these steps:

1. Open the sample database Northwind.mdb.
2. Create a module and type the following line in the Declarations section if it is not already there:

   Option Explicit
   					

3. Type or paste the following functions into the new module:

   Global Const SUCCESS_SUCCESS = 0
   Const PermOpenRun = 1
   Const PermReadDes = 2
   Const PermReadData = 3
   Const PermModDes = 4
   Const PermAdmin = 5
   Const PermModData = 6
   Const PermDeleteData = 7
   Const PermInsertData = 8
   
   ' ****************************************
   ' FUNCTION: UtilSecTbls()
   '
   ' Returns: True if the function completes successfully of false
   ' if it does Not.
   ' ****************************************
   Function UtilSecTbls() As Boolean
   
      On Error GoTo Err_UtilSecTbls
      Dim Mydb As Database, DBObjs As Recordset, StrUsrName As String
      Dim strClass As String, GrpRs As Recordset, SecRs As Recordset
      Dim UsrRecs As Recordset, lngAdmin, lngExecute, lngReadDef, _
        lngWritedef, lngReadData, lngUpdateData, lngDeleteData, _
        lngInsertData As Long
   
      ' Try to create the tables; if no error, continue.
      If CreateTbls() Then
         ' Set the database object and open the recordsets.
         Set Mydb = CurrentDb()
         Set SecRs = Mydb.OpenRecordset("UTL_UsrPermTable")
         Set UsrRecs = Mydb.OpenRecordset("UTL_UsrTable")
         Set DBObjs = Mydb.OpenRecordset("UTL_DBobjstable")
   
         lngAdmin = dbSecFullAccess
         ' Loop through the tables of Users and groups.
         Do While Not UsrRecs.EOF
         DBObjs.MoveFirst
         ' Store the group name or user name.
         StrUsrName = UsrRecs!AccountId
         ' Now loop through the table of objects so that you can get
         ' the permissions to the objects for each user or group.
         Do While Not DBObjs.EOF
         ' Set variables initially to 9999 so you can use them only
         ' when a user or group might have that permission.
         lngExecute = 9999
         lngReadDef = 9999
         lngWritedef = 9999
         lngReadData = 999
         lngUpdateData = 9999
         lngDeleteData = 9999
         lngInsertData = 9999
   
         ' Check to see what kind of an object you are using and set
         ' the variables to the appropriate security setting.
         Select Case DBObjs!DocType
   
           Case "Forms", "Reports"
               If DBObjs!DocType = "Forms" Then
                   strClass = "Forms"
               Else
                   strClass = "Reports"
               End If
             lngExecute = acSecFrmRptExecute
             lngReadDef = acSecFrmRptReadDef
             lngWritedef = acSecFrmRptWriteDef
   
           Case "Tables", "Queries"
             strClass = "Tables"
             lngReadDef = dbSecReadDef
             lngWritedef = dbSecWriteDef
             lngReadData = dbSecRetrieveData
             lngUpdateData = dbSecReplaceData
             lngDeleteData = dbSecInsertData
             lngInsertData = dbSecInsertData
   
           Case "Modules"
             strClass = "Modules"
             lngReadDef = acSecModReadDef
             lngWritedef = acSecModWriteDef
   
           Case "Macros"
             strClass = "Scripts"
             lngReadDef = acSecMacReadDef
             lngWritedef = acSecMacWriteDef
             lngExecute = acSecMacExecute
   
         End Select
   
    ' If you need to check for Open-Run permissions for the object
      If lngExecute <> 9999 Then
    ' Call the GetPermissions function to check the permission.
    ' If it returns true, then add a record in the Usr Permissions table
      If (GetPermissions(UsrRecs!AccountId, strClass, DBObjs!Docname) _
        And lngExecute) = lngExecute Then
            SecRs.AddNew
            SecRs!docId = DBObjs!docId
            SecRs!AccountId = StrUsrName
            SecRs!PermissionsId = PermOpenRun
            SecRs.Update
       End If
     End If
    ' Check to see if you have Read Design permissions.
    If lngReadDef <> 9999 Then
      If (GetPermissions(UsrRecs!AccountId, strClass, DBObjs!Docname) _
        And dbSecFullAccess) = dbSecFullAccess Then
           SecRs.AddNew
           SecRs!docId = DBObjs!docId
           SecRs!AccountId = StrUsrName
           SecRs!PermissionsId = PermReadDes
           SecRs.Update
       End If
     End If
   
     ' Check to see if you have Administer permissions to the object.
     If (GetPermissions(UsrRecs!AccountId, strClass, DBObjs!Docname) _
         And dbSecFullAccess) = dbSecFullAccess Then
            SecRs.AddNew
            SecRs!docId = DBObjs!docId
            SecRs!AccountId = StrUsrName
            SecRs!PermissionsId = PermAdmin
            SecRs.Update
     End If
   
     ' Check to see if you have Modify Design permissions.
     If lngWritedef <> 9999 Then
      If (GetPermissions(UsrRecs!AccountId, strClass, DBObjs!Docname) _
           And lngWritedef) = lngWritedef Then
              SecRs.AddNew
              SecRs!docId = DBObjs!docId
              SecRs!AccountId = StrUsrName
              SecRs!PermissionsId = PermModDes
              SecRs.Update
       End If
    End If
   
    ' Check to see if you have Read Data permissions.
    If lngReadData <> 9999 Then
      If (GetPermissions(UsrRecs!AccountId, strClass, DBObjs!Docname) _
            And lngReadData) = lngReadData Then
               SecRs.AddNew
               SecRs!docId = DBObjs!docId
               SecRs!AccountId = StrUsrName
               SecRs!PermissionsId = PermReadData
               SecRs.Update
      End If
    End If
   
    ' Check to see if you have insert permissions.
    If lngInsertData <> 9999 Then
      If (GetPermissions(UsrRecs!AccountId, strClass, DBObjs!Docname) _
           And lngInsertData) = lngInsertData Then
              SecRs.AddNew
              SecRs!docId = DBObjs!docId
              SecRs!AccountId = StrUsrName
              SecRs!PermissionsId = PermInsertData
              SecRs.Update
       End If
    End If
   
    ' Check to see if you have Update Data permissions.
    If lngUpdateData <> 9999 Then
      If (GetPermissions(UsrRecs!AccountId, strClass, DBObjs!Docname) _
           And lngUpdateData) = lngUpdateData Then
              SecRs.AddNew
              SecRs!docId = DBObjs!docId
              SecRs!AccountId = StrUsrName
              SecRs!PermissionsId = PermModData
              SecRs.Update
         End If
       End If
   
      ' Check to see if you have Delete Data permissions.
      If lngDeleteData <> 9999 Then
       If (GetPermissions(UsrRecs!AccountId, strClass, DBObjs!Docname) _
           And lngDeleteData) = lngDeleteData Then
              SecRs.AddNew
              SecRs!docId = DBObjs!docId
              SecRs!AccountId = StrUsrName
              SecRs!PermissionsId = PermDeleteData
              SecRs.Update
          End If
        End If
        DBObjs.MoveNext
        Loop
         UsrRecs.MoveNext
        Loop
        DBObjs.Close
        UsrRecs.Close
        SecRs.Close
        Mydb.Close
        UtilSecTbls = True
      Else
        MsgBox "Tables were not successfully created."
        UtilSecTbls = False
      End If
   
   Bye_UtilSecTbls:
      Exit Function
   
   Err_UtilSecTbls:
      ' If an error occurs, display the message and terminate the
      ' .. function, returning the error number.
      MsgBox Err & " " & Error$
      UtilSecTbls = False
      Resume Bye_UtilSecTbls
   
   End Function
   
   ' ****************************************
   ' FUNCTION: CreateTbls()
   '
   ' Inputs:  UserGrpName - name of a user or group account
   '          ObjClass    - name of an object container
   '          ObjName     - name of an object document
   '
   ' Returns: True if the function completes successfully and false if
   ' it does not. It will also display an error message if it does not
   ' complete.
   ' ****************************************
   
   Function CreateTbls() As Boolean
      On Error GoTo Err_Createtbls
      Dim Secdb As Database, myWs As Workspace, grp As Group
      Dim Usr As User, Lngdocid As Long
      Dim SecTd As TableDef, secqd As QueryDef, mydoc As Document
      Dim DocRs As Recordset, UsrRs As Recordset
   
      ' Set the Workgroup and database objects.
      Set myWs = DBEngine.Workspaces(0)
      Set Secdb = CurrentDb
   
      ' Check to see if the Table of users and groups exist. If it
      ' does not exist create the table. If it does, delete the records
      ' from the table.
   
      If IsTableQuery("", "UTL_USRTable") Then
         Secdb.Execute "Delete * from UTL_USRTable;"
      Else
         Secdb.Execute "CREATE TABLE UTL_USRTable (AccountID " & _
             "Text(20) CONSTRAINT AccountIDPK PRIMARY KEY, Type " & _
             "TEXT(10));"
      End If
   
      Set UsrRs = Secdb.OpenRecordset("UTL_UsrTable")
      myWs.Groups.Refresh
      For Each grp In myWs.Groups
         UsrRs.AddNew
         UsrRs!AccountId = grp.Name
         UsrRs!Type = "Group"
         UsrRs.Update
      Next grp
      myWs.Users.Refresh
   
      For Each Usr In myWs.Users
         If Usr.Name <> "Creator" And Usr.Name <> "Engine" Then
            UsrRs.AddNew
            UsrRs!AccountId = Usr.Name
            UsrRs!Type = "User"
            UsrRs.Update
         End If
      Next Usr
      UsrRs.Close
   
      ' Check to see if the Table of Permissions exists.
      ' If it does not exist create the table and fill in the records.
      If Not IsTableQuery("", "UTL_PermTable") Then
        Secdb.Execute "CREATE TABLE UTL_PermTable (PermissionsID " & _
            "Long CONSTRAINT PermIDPK PRIMARY KEY, PermissionsDesc " & _
            "TEXT(20));"
        Secdb.Execute "Insert into UTL_PermTable " & _
            "(PermissionsID,PermissionsDesc) Values (1,'OpenRun')"
        Secdb.Execute "Insert into UTL_PermTable " & _
            "(PermissionsID,PermissionsDesc) Values (2,'Read Design')"
        Secdb.Execute "Insert into UTL_PermTable " & _
            "(PermissionsID,PermissionsDesc) Values (3,'Read Data')"
        Secdb.Execute "Insert into UTL_PermTable " & _
            "(PermissionsID,PermissionsDesc) Values (4,'Modify Design')"
        Secdb.Execute "Insert into UTL_PermTable " & _
            "(PermissionsID,PermissionsDesc) Values (5,'Admininster')"
        Secdb.Execute "Insert into UTL_PermTable " & _
            "(PermissionsID,PermissionsDesc) Values (6,'Update Data')"
        Secdb.Execute "Insert into UTL_PermTable " & _
           "(PermissionsID,PermissionsDesc) Values (7,'Delete Data')"
        Secdb.Execute "Insert into UTL_PermTable " & _
           "(PermissionsID,PermissionsDesc) Values (8,'Insert Data')"
      End If
   
   ' Check to see if the Table of database objects exists.
   ' If it does not exist, create the table. If it does, then delete the
   ' records from the table.
   If IsTableQuery("", "UTL_dbObjstable") Then
     Secdb.Execute "Delete * from UTL_DbobjsTable;"
   Else
    Secdb.Execute "CREATE TABLE UTL_DbObjsTable (DocID Long " & _
       "CONSTRAINT DocIDPK PRIMARY KEY, Docname TEXT(64), " & _
       "docType Text(10));"
   End If
   
   ' Fill in the data for the table by going through the TableDefs,
   ' QueryDefs, and documents collections.
     Set DocRs = Secdb.OpenRecordset("UTL_DBobjstable")
     Lngdocid = 1
   
     For Each SecTd In Secdb.TableDefs
   
    ' Filter out Temp objects and System objects and loop through the
    ' TableDefs and QueryDefs collection.
   If Left(SecTd.Name, 4) <> "Msys" And Left(SecTd.Name, 1) <> "~" Then
       DocRs.AddNew
       DocRs!docId = Lngdocid
       DocRs!Docname = SecTd.Name
       DocRs!DocType = "Tables"
       DocRs.Update
       Lngdocid = Lngdocid + 1
   End If
   Next SecTd
   For Each secqd In Secdb.QueryDefs
       If Left(secqd.Name, 1) <> "~" Then
          DocRs.AddNew
          DocRs!docId = Lngdocid
          DocRs!Docname = secqd.Name
          DocRs!DocType = "Queries"
          DocRs.Update
          Lngdocid = Lngdocid + 1
       End If
   Next secqd
   
   ' Loop through the Forms Document Collection.
   For Each mydoc In Secdb.Containers!Forms.Documents
       DocRs.AddNew
       DocRs!docId = Lngdocid
       DocRs!Docname = mydoc.Name
       DocRs!DocType = "Forms"
       DocRs.Update
       Lngdocid = Lngdocid + 1
   Next mydoc
   
   ' Loop through the Reports Document Collection.
   For Each mydoc In Secdb.Containers!Reports.Documents
      DocRs.AddNew
      DocRs!docId = Lngdocid
      DocRs!Docname = mydoc.Name
      DocRs!DocType = "Reports"
      DocRs.Update
      Lngdocid = Lngdocid + 1
   Next mydoc
   
   ' Loop through the Macros Document Collection.
   For Each mydoc In Secdb.Containers!Scripts.Documents
      DocRs.AddNew
      DocRs!docId = Lngdocid
      DocRs!Docname = mydoc.Name
      DocRs!DocType = "Macros"
      DocRs.Update
      Lngdocid = Lngdocid + 1
   Next mydoc
   
   ' Loop through the Modules Document Collection.
   For Each mydoc In Secdb.Containers!Modules.Documents
      DocRs.AddNew
      DocRs!docId = Lngdocid
      DocRs!Docname = mydoc.Name
      DocRs!DocType = "Modules"
      DocRs.Update
      Lngdocid = Lngdocid + 1
   Next mydoc
   DocRs.Close
   
   ' Check to see if the Table of users permissions exists. If it does
   ' not exist, create the table. If it does, then delete the records
   ' from the table.
   
   If IsTableQuery("", "UTL_UsrPermtable") Then
      Secdb.Execute "Delete * From UTL_UsrPermTable"
   Else
     Secdb.Execute "CREATE TABLE UTL_UsrPermTable (AccountID " & _
        "Text(20), docId Long,PermissionsId Long);"
   End If
   
   Secdb.Close
   CreateTbls = True
   
   Bye_CreateTbls:
   Exit Function
   
   Err_Createtbls:
   ' If an error occurs, display the message and terminate the
   ' .. function, returning the error number.
   MsgBox Err & " " & Error$
   CreateTbls = False
   Resume Bye_CreateTbls
   End Function
   
   ' ****************************************
   ' FUNCTION: GetPermissions()
   '
   ' Inputs:  UserGrpName - name of a user or group account
   '          ObjClass    - name of an object container
   '          ObjName     - name of an object document
   '
   ' Returns: Value of Permissions property or error number
   '          that was generated.
   ' ****************************************
   Function GetPermissions&(UserGrpName$, ObjClass$, ObjName$)
   
   On Error GoTo Err_GetPermissions
   
   ' Set DB to the current database, and set the DOC variable
   ' .. to the object specified in the arguments.
   Dim Db As Database, DOC As Document
   Set Db = DBEngine.Workspaces(0).Databases(0)
   Set DOC = Db.Containers(ObjClass).Documents(ObjName)
   
   ' Set the UserName property of the document to the
   ' .. user or group you want to obtain the permissions for.
   DOC.UserName = UserGrpName
   
   ' Get the permissions value.
   GetPermissions = DOC.Permissions
   
   Bye_GetPermissions:
   Exit Function
   
   Err_GetPermissions:
   ' If an error occurs, display the message and terminate the
   ' .. function, returning the error number.
   MsgBox Err & " " & Error$
   GetPermissions = Err
   Resume Bye_GetPermissions
   End Function
   
   '********************************************************
   ' FUNCTION: IsTableQuery()
   '
   ' PURPOSE: Determine if a table or query exists.
   '
   ' ARGUMENTS:
   '   DbName: The name of the database. If the database name
   '           is "" the current database is used.
   '    TName: The name of a table or query.
   '
   ' RETURNS: True (it exists) or False (it does not exist).
   '
   '********************************************************
   Function IsTableQuery(DbName As String, TName As String) As Integer
   Dim Db As Database, Found As Integer, Test As String
   Const NAME_NOT_IN_COLLECTION = 3265
   
   ' Assume the table or query does not exist.
   Found = False
   
   ' Trap for any errors.
   On Error Resume Next
   
   ' If the database name is empty...
       If Trim$(DbName) = "" Then
          ' Set Db to the current Db.
          Set Db = CurrentDb()
      Else
       ' Otherwise, set Db to the specified open database.
         Set Db = DBEngine.Workspaces(0).OpenDatabase(DbName)
   
        ' See if an error occurred.
        If Err Then
           MsgBox "Could not find database to open: " & DbName
           IsTableQuery = False
           Exit Function
        End If
     End If
   
   ' See if the name is in the Tables collection.
   Test = Db.TableDefs(TName).Name
      If Err <> NAME_NOT_IN_COLLECTION Then Found = True
   
   ' Reset the error variable.
      Err = 0
   
   ' See if the name is in the Queries collection.
   Test = Db.QueryDefs(TName$).Name
     If Err <> NAME_NOT_IN_COLLECTION Then Found = True
   
       Db.Close
       IsTableQuery = Found
   
   End Function
   
   					

4. To test these functions, type the following line in the Immediate window, and then press ENTER:

   ?UtilSecTbls()
   						

   Note that a TRUE is returned and that the following tables are created:
   
   UTL_DbObjsTable (This contains the objects of the database with a primary key on a field called DodID, which is a Long Integer field, DocName, which holds the table, query, form, report, macro or module name, and DocType, which is used to identify it as a table, query, form, report, macro or module)
   
   UTL_PermTable (This contains a table with all of the possible permissions a user can have on an object with a field called PermissionsID as the primary key, which is a Long Integer field and PermissionsDesc, which is a text field and stores either OpenRun, Read Data, Modify Data, and so on.)
   
   UTL_USRTable (This table contains all of the user and group accounts for the Workgroup with a field called AccountId as the primary key, which holds the user or group name and Type, which is set to User or Group)
   
   UTL_UsrPermTable (This is a table used to link the other tables together and contains all of the permissions for each user and group to a specific object. This table contains AccountID, DocID, and PermissionsID).
5. Close the Immediate window.

Creating the Query That Joins the Tables

To create a new query that joins all of the tables, you should link the UTL_DbObjsTable to the UTL_UsrPermTable based on the DocId field, the UTL_USRTable to the UTL_UsrPermTable based on the AccountID field, and the UTL_PermTable to the UTL_UsrPermTable based on the PermissionsId field.

You can now design your reports to group by user name, group name, object type, permissions, and any combination of the above.

For additional information about using DAO to create group and user accounts, about how to assign users to group accounts, and about how to assign or view permissions, please see the following article in the Microsoft Knowledge Base: For additional information about how to see if a table or query already exists, please see the following article in the Microsoft Knowledge Base: