Checking Permissions for a Specific Object : User Account « Access « VBA / Excel / Access / Word

1. VBA / Excel / Access / Word
2. Access
3. User Account

Checking Permissions for a Specific Object

 
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 

 

Related examples in the same category