в 16:33, 26 мая 2010

2010-05-26T16:33:00Z

Admin: 1 версия

2010-05-26T12:47:01Z

1 версия

Новая страница

==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>

← Предыдущая	Версия 16:33, 26 мая 2010
(нет различий)

VBA/Excel/Access/Word/Access/User Account - История изменений

в 16:33, 26 мая 2010

Admin: 1 версия