ACC97: How to Create Your Own Custom Security ReportsID: Q179703
|
Advanced: Requires expert coding, interoperability, and multiuser skills.
The Database Documenter does not enable you to view a report on a per user
basis or 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, including, but not limited to, the implied warranties of
merchantability and/or fitness for a particular purpose. This article assumes that you
are familiar with the programming language being demonstrated and the tools used to
create and debug procedures. Microsoft support professionals 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 needs. If you have limited
programming experience, you may want to contact a Microsoft Certified Solution Provider
or the Microsoft fee-based consulting line at (800) 936-5200. For more information about
Microsoft Certified Solution Providers, please see the following page on the World Wide Web:
http://www.microsoft.com/mcsp/For more information about the support options available from Microsoft, please see the following page on the World Wide Web:
http://www.microsoft.com/support/supportnet/overview/overview.asp
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.
Option Explicit
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
? UtilSecTbls() 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).
For more 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 articles in the Microsoft Knowledge Base:
Q124240 ACC2: Only Admins Group Members Can List Groups They Belong To
Q112063 ACC: How to Add a User to a Group with CreateUser Method
Q112106 ACC: How to Use DAO to Assign or View PermissionsFor more information about how to use see if a table or query already exists, please see the following article in the Microsoft Knowledge Base:
Q113549 ACC: How to Determine If a Table or Query Exists
Additional query words: 8.00 inf
Keywords : PgmHowto
Version : WINDOWS:97
Platform : WINDOWS
Issue type : kbhowto kbinfo Last Reviewed: July 6, 1999