VBA/Excel/Access/Word/Access/User Account

Add a new user

 
Sub UserAdd()
    Dim mySpace As Workspace
    Dim usrMark As User
    Dim strUsersPID As String
    Set mySpace = DBEngine(0)
    strUsersPID = "1234abcd"
    Set usrMark = mySpace.CreateUser("Mark")
    usrMark.Password = "Doc"
    usrMark.PID = strUsersPID
    mySpace.Users.Append usrMark
End Sub

Changing a User Password with SQL command

 
Sub ChangeUserPassword() 
    Dim conn As ADODB.Connection 
    On Error GoTo ErrorHandler 
    Set conn = CurrentProject.Connection 
    conn.Execute "ALTER USER yourName PASSWORD primate passw" 
ExitHere: 
    If Not conn Is Nothing Then 
        If conn.State = adStateOpen Then conn.Close 
    End If 
    Set conn = Nothing 
    Exit Sub 
ErrorHandler: 
    Debug.Print Err.Number & ":" & Err.Description 
    Resume ExitHere 
End Sub

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

Creating a User Account

 
Sub Create_User() 
    Dim cat As ADOX.Catalog 
    Dim conn As ADODB.Connection 
    Dim strDB As String 
    Dim strSysDb As String 
    Dim strName As String 
    On Error GoTo ErrorHandle 
    strDB = CurrentProject.Path & "\mydb.mdb" 
    strSysDb = CurrentProject.Path &  "\mydb.mdw" 
    strName = "PowerUser" 
    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 
    With cat 
        .ActiveConnection = conn 
        .Users.Append strName, "star" 
    End With 
    Debug.Print "Successfully created " & strName & " user account." 
ExitHere: 
    Set cat = Nothing 
    conn.Close 
    Set conn = Nothing 
    Exit Sub 
ErrorHandle: 
    If Err.Number = -2147467259 Then 
        MsgBox strName & " user already exists." 
    Else 
        MsgBox Err.Description 
    End If 
    Resume ExitHere 
End Sub

Creating a User Account with SQL command

 
Sub CreateUserAccount()
    Dim conn As ADODB.Connection
    On Error GoTo ErrorHandler
    Set conn = CurrentProject.Connection
    conn.Execute "CREATE USER yourName yourpass 0302"
ExitHere:
    If Not conn Is Nothing Then
        If conn.State = adStateOpen Then conn.Close
    End If
    Set conn = Nothing
    Exit Sub
ErrorHandler:
    Debug.Print Err.Number & ":" & Err.Description
    Resume ExitHere
End Sub

Deleting a User Account

 
Sub Delete_User() 
    Dim cat As ADOX.Catalog 
    Dim conn As ADODB.Connection 
    Dim strDB As String 
    Dim strSysDb 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 
    With cat 
        .ActiveConnection = conn 
        .Users.Delete "UserName" 
    End With 
ExitHere: 
    Set cat = Nothing 
    conn.Close 
    Set conn = Nothing 
    Exit Sub 
ErrorHandle: 
    If Err.Number = 3265 Then 
        cat.Users.Append "UserName", "star" 
        Resume 
    Else 
        MsgBox Err.Description 
        Resume ExitHere 
    End If 
End Sub

Enumerate group and users

 
Sub EnumGroupsAndUsers()
    Dim grp As Group
    Dim usr As User
    For Each usr In DBEngine(0).Users
        Debug.Print usr.Name
        For Each grp In usr.Groups
            Debug.Print vbTab; grp.Name
        Next
    Next
End Sub

Listing All User Accounts

 
Sub List_Users() 
    Dim conn As ADODB.Connection 
    Dim cat As ADOX.Catalog 
    Dim myUser As New ADOX.User 
    Dim strDB As String 
    Dim strSysDb As String 
    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 
    For Each myUser In cat.Users 
        Debug.Print myUser.Name 
    Next 
    Set cat = Nothing 
    conn.Close 
    Set conn = Nothing 
End Sub

Retrieving the Name of the Object Owner

 
Sub Get_ObjectOwner()
    Dim conn As ADODB.Connection
    Dim cat As ADOX.Catalog
    Dim strObjName As Variant
    Dim strDB As String
    Dim strSysDb As String
    strDB = CurrentProject.Path & "\mydb.mdb"
    strSysDb = CurrentProject.Path & "\mydb.mdw"
    strObjName = "Customers"
    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
    Debug.Print "The owner of the " & strObjName & " table is " & vbCr _
      & cat.GetObjectOwner(strObjName, adPermObjTable) & "."
    Set cat = Nothing
    conn.Close
    Set conn = Nothing
End Sub

Setting User Permissions for a Database

 
Sub Set_UserDbPermissions() 
    Dim conn As ADODB.Connection 
    Dim cat As ADOX.Catalog 
    Dim strDB As String 
    Dim strSysDb 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" 
    cat.Users("PowerUser").SetPermissions " ", adPermObjDatabase, _ 
            adAccessSet, adRightExclusive 
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

Setting User Permissions for an Object

 
Sub Set_UserObjectPermissions() 
    Dim conn As ADODB.Connection 
    Dim cat As ADOX.Catalog 
    Dim strDB As String 
    Dim strSysDb 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" 
    cat.Users("PowerUser").SetPermissions "Customers", _ 
        adPermObjTable, _ 
        adAccessSet, _ 
        adRightRead Or _ 
        adRightInsert Or _ 
        adRightUpdate Or _ 
        adRightDelete 
ExitHere: 
    Set cat = Nothing 
    conn.Close 
    Set conn = Nothing 
    Exit Sub 
ErrorHandle: 
    If Err.Number = -2147467259 Then 
        Debug.Print "PowerUser user already exists." 
        Resume Next 
    Else 
        Debug.Print Err.Description 
        Resume ExitHere 
    End If 
End Sub

Setting User Permissions for Containers

 
Sub Set_UserContainerPermissions() 
    Dim conn As ADODB.Connection 
    Dim cat As ADOX.Catalog 
    Dim strDB As String 
    Dim strSysDb 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" 
    cat.Users("PowerUser").SetPermissions Null, _ 
        adPermObjTable, _ 
        adAccessSet, _ 
        adRightRead Or _ 
        adRightInsert Or _ 
        adRightUpdate Or _ 
        adRightDelete, adInheritNone 
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