Option Compare Database
Option Explicit
' Routine to Obtain a users permission Group
' Count ReadWrite Groups
Private Const JET_SCHEMA_USERROSTER = "{947bb102-5d43-11d1-bdbf-00c04fb92675}"
Private Const UPDATE_PERMISSION_GROUP = "ReadWrite"
Private Const DEVELOPER_USER_NAME = "Backdoor"
Sub test()
If CurrentUser() <> DEVELOPER_USER_NAME Then
Debug.Print "Is allowed in "; isUserAllowedIn(CurrentUser())
End If
End Sub
Public Function isUserAllowedIn(strUser As String) As Boolean
Dim strUserGroup As Variant
Dim intUpdateCount As Integer
strUserGroup = GetUsergroup(CurrentUser())
intUpdateCount = GetNoUpdateLogins()
Debug.Print "Currently Logged In "; CurrentUser()
Debug.Print "Is a member of the Update group "; strUserGroup
Debug.Print "Count of Update Users "; intUpdateCount
If intUpdateCount > 1 Then
isUserAllowedIn = False
Else
isUserAllowedIn = True
End If
End Function
Private Function GetUsergroup(strLoggingOn As String) As String
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim i As Integer
Dim strUser As String
Dim fFound As Boolean
On Error GoTo Err_handler
Set cn = CurrentProject.Connection
' The user roster is exposed as a provider-specific schema rowset
' in the Jet 4.0 OLE DB provider. You have to use a GUID to
' reference the schema, as provider-specific schemas are not
' listed in ADO's type library for schema rowsets
Set rs = cn.OpenSchema(adSchemaProviderSpecific, , JET_SCHEMA_USERROSTER)
fFound = False
While Not rs.EOF And Not fFound
' rs.fields(1) is fixed length, the text is terminated by asc 0 and padded out with asc 32
i = InStr(1, rs.Fields(1), Chr(0))
strUser = Left$(rs.Fields(1), i - 1)
If strLoggingOn = strUser Then
GetUsergroup = GetUpdatePermissionGroup(strUser)
fFound = True
End If
rs.MoveNext
Wend
Exit_Handler:
Set rs = Nothing
Exit Function
Err_handler:
MsgBox Err & " " & Err.Description
Resume Exit_Handler
End Function
Private Function GetUpdatePermissionGroup(strUser As String) As Boolean
' Returns true if the User currently logged in
' is in the Update group
Dim ws As Workspace, usr As User, grp As Group
On Error GoTo Err_handler
Set ws = DBEngine.Workspaces(0)
GetUpdatePermissionGroup = False
For Each usr In ws.Users
'Debug.Print "Users/strUser "; usr.Name, strUser
If usr.Name = strUser Then
For Each grp In usr.Groups
'Debug.Print "groups "; grp.Name
If grp.Name = UPDATE_PERMISSION_GROUP Then
GetUpdatePermissionGroup = True
End If
Next
End If
Next
Exit_Handler:
Exit Function
Err_handler:
MsgBox Err & " " & Err.Description
Resume Exit_Handler
End Function
Private Function GetNoUpdateLogins() As Integer
' Loops through all logged on users and
' and counts up those in the Update group
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim i As Integer
Dim strUser As String
On Error GoTo Err_handler
Set cn = CurrentProject.Connection
' The user roster is exposed as a provider-specific schema rowset
' in the Jet 4.0 OLE DB provider. You have to use a GUID to
' reference the schema, as provider-specific schemas are not
' listed in ADO's type library for schema rowsets
Set rs = cn.OpenSchema(adSchemaProviderSpecific, , JET_SCHEMA_USERROSTER)
While Not rs.EOF
' rs.fields(1) is fixed length, the text is terminated by asc 0 and padded out with asc 32
i = InStr(1, rs.Fields(1), Chr(0))
strUser = Left$(rs.Fields(1), i - 1)
If isUpdateGroup(strUser) Then
GetNoUpdateLogins = GetNoUpdateLogins + 1
End If
rs.MoveNext
Wend
Exit_Handler:
Set rs = Nothing
Exit Function
Err_handler:
MsgBox Err & " " & Err.Description
Resume Exit_Handler
End Function
Private Function isUpdateGroup(strUser As String) As Boolean
' checks if a user is in the Update group
' return True if so
Dim ws As Workspace, usr As User, grp As Group
On Error GoTo Err_handler
Set ws = DBEngine.Workspaces(0)
For Each usr In ws.Users
If usr.Name = strUser Then
For Each grp In usr.Groups
If grp.Name = UPDATE_PERMISSION_GROUP Then
isUpdateGroup = True
End If
Next
End If
Next
Exit_Handler:
Exit Function
Err_handler:
MsgBox Err & " " & Err.Description
Resume Exit_Handler
End Function