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

Add a new user

   <source lang="vb">

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

</source>
   
  

Changing a User Password with SQL command

   <source lang="vb">

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

</source>
   
  

Checking Permissions for a Specific Object

   <source lang="vb">

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

</source>
   
  

Creating a User Account

   <source lang="vb">

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

</source>
   
  

Creating a User Account with SQL command

   <source lang="vb">

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

</source>
   
  

Deleting a User Account

   <source lang="vb">

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

</source>
   
  

Enumerate group and users

   <source lang="vb">

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

</source>
   
  

Listing All User Accounts

   <source lang="vb">

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

</source>
   
  

Retrieving the Name of the Object Owner

   <source lang="vb">

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

</source>
   
  

Setting User Permissions for a Database

   <source lang="vb">

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

</source>
   
  

Setting User Permissions for an Object

   <source lang="vb">

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

</source>
   
  

Setting User Permissions for Containers

   <source lang="vb">

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

</source>