Mega Code Archive
Checking Permissions for a Specific Object
<![CDATA[
Sub GetObjectPermissions(strUserName As String, varObjName As Variant, lngObjType As ADOX.ObjectTypeEnum)
Dim conn As ADODB.Connection
Dim cat As ADOX.Catalog
Dim strDB As String
Dim strSysDb As String
Dim listPerms As Long
Dim strPermsTypes As String
On Error GoTo ErrorHandle
strDB = CurrentProject.Path & "\mydb.mdb"
strSysDb = CurrentProject.Path & "\mydb.mdw"
Set conn = New ADODB.Connection
With conn
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Properties("Jet OLEDB:System Database") = strSysDb
.Properties("User ID") = "Developer"
.Properties("Password") = "mypass"
.Open strDB
End With
Set cat = New ADOX.Catalog
cat.ActiveConnection = conn
cat.Users.Append "PowerUser", "star"
listPerms = cat.Users(strUserName) _
.GetPermissions(varObjName, lngObjType)
Debug.Print listPerms
If (listPerms And ADOX.RightsEnum.adRightCreate) = adRightCreate Then
Debug.Print "adRightCreate" & vbCr
End If
If (listPerms And RightsEnum.adRightRead) = adRightRead Then
Debug.Print "adRightRead" & vbCr
End If
If (listPerms And RightsEnum.adRightUpdate) = adRightUpdate Then
Debug.Print "adRightUpdate" & vbCr
End If
If (listPerms And RightsEnum.adRightDelete) = adRightDelete Then
Debug.Print "adRightDelete" & vbCr
End If
If (listPerms And RightsEnum.adRightInsert) = adRightInsert Then
Debug.Print "adRightInsert" & vbCr
End If
If (listPerms And RightsEnum.adRightReadDesign) = adRightReadDesign Then
Debug.Print "adRightReadDesign"
End If
ExitHere:
Set cat = Nothing
conn.Close
Set conn = Nothing
Exit Sub
ErrorHandle:
If Err.Number = -2147467259 Then
Resume Next
Else
MsgBox Err.Description
Resume ExitHere
End If
End Sub
]]>