Master 95 #1

home *** CD-ROM | disk | FTP | other *** search

/ Master 95 #1 / MASTER95_1.iso / microsof / vbasic4 / vb4-6.cab / grpsusrs.frm (.txt) < prev next >

Wrap

Visual Basic Form | 1995-07-26 | 23.4 KB | 786 lines

VERSION 4.00 Begin VB.Form frmGroupsUsers BorderStyle = 3 'Fixed Dialog Caption = "Groups/Users/Permissions" ClientHeight = 5010 ClientLeft = 1770 ClientTop = 1815 ClientWidth = 5760 Height = 5415 HelpContextID = 2016088 Icon = "GRPSUSRS.frx":0000 Left = 1710 LinkTopic = "Form1" LockControls = -1 'True MaxButton = 0 'False MDIChild = -1 'True MinButton = 0 'False ScaleHeight = 5010 ScaleWidth = 5760 Top = 1470 Width = 5880 Begin VB.ComboBox cboOwners Height = 300 Left = 3360 Style = 2 'Dropdown List TabIndex = 28 Top = 2360 Width = 2295 End Begin VB.Frame fraPermissions Caption = "Permissions" Height = 1695 Left = 2520 TabIndex = 16 Top = 2760 Width = 3135 Begin VB.CommandButton cmdAssign Caption = "&Assign" Height = 300 Left = 120 TabIndex = 25 Top = 1280 Width = 1400 End Begin VB.CheckBox chkDeleteData Caption = "DeleteData" Height = 255 Left = 1680 TabIndex = 24 Top = 1320 Width = 1335 End Begin VB.CheckBox chkInsertData Caption = "InsertData" Height = 255 Left = 1680 TabIndex = 23 Top = 1000 Width = 1335 End Begin VB.CheckBox chkUpdateData Caption = "UpdateData" Height = 255 Left = 1680 TabIndex = 22 Top = 680 Width = 1335 End Begin VB.CheckBox chkReadData Caption = "ReadData" Height = 255 Left = 1680 TabIndex = 21 Top = 360 Width = 1335 End Begin VB.CheckBox chkAdminister Caption = "Administer" Height = 255 Left = 120 TabIndex = 20 Top = 1000 Width = 1455 End Begin VB.CheckBox chkModifyDesign Caption = "ModifyDesign" Height = 255 Left = 120 TabIndex = 19 Top = 680 Width = 1575 End Begin VB.CheckBox chkReadDesign Caption = "ReadDesign" Height = 255 Left = 120 TabIndex = 18 Top = 360 Width = 1455 End End Begin VB.OptionButton optGroups Caption = "Groups" Height = 255 Left = 1200 TabIndex = 2 Top = 120 Width = 975 End Begin VB.OptionButton optUsers Caption = "Users" Height = 255 Left = 120 TabIndex = 1 Top = 120 Value = -1 'True Width = 855 End Begin VB.CommandButton cmdClose Caption = "&Close" Height = 375 Left = 2160 TabIndex = 0 Top = 4560 Width = 1335 End Begin VB.ListBox lstTablesQuerys Height = 1620 ItemData = "GRPSUSRS.frx":030A Left = 2520 List = "GRPSUSRS.frx":0311 MultiSelect = 2 'Extended TabIndex = 15 Top = 480 Width = 3135 End Begin VB.PictureBox picUsers Appearance = 0 'Flat BorderStyle = 0 'None ForeColor = &H80000008& Height = 3975 Left = 120 ScaleHeight = 3975 ScaleWidth = 2205 TabIndex = 3 Top = 480 Width = 2205 Begin VB.CommandButton cmdPassword Caption = "&Set/Clear Password" Height = 300 Left = 120 TabIndex = 26 Top = 3615 Width = 1935 End Begin VB.ListBox lstUsersGroups Height = 1035 Left = 0 MultiSelect = 1 'Simple TabIndex = 12 Top = 2400 Width = 2175 End Begin VB.CommandButton cmdDeleteUser Caption = "&Delete" Height = 300 Left = 1200 TabIndex = 10 Top = 1800 Width = 975 End Begin VB.CommandButton cmdNewUser Caption = "&New" Height = 300 Left = 0 TabIndex = 9 Top = 1800 Width = 975 End Begin VB.ListBox lstUsers Height = 1620 Left = 0 TabIndex = 4 Top = 0 Width = 2175 End Begin VB.Label lblLabels Caption = "Groups Belonged to:" Height = 255 Index = 1 Left = 0 TabIndex = 11 Top = 2160 Width = 2055 End End Begin VB.PictureBox picGroups Appearance = 0 'Flat BorderStyle = 0 'None ForeColor = &H80000008& Height = 3615 Left = 120 ScaleHeight = 3615 ScaleWidth = 2205 TabIndex = 5 Top = 480 Visible = 0 'False Width = 2205 Begin VB.ListBox lstGroupsUsers Height = 1035 Left = 0 MultiSelect = 1 'Simple TabIndex = 13 Top = 2400 Width = 2175 End Begin VB.CommandButton cmdDeleteGroup Caption = "&Delete" Height = 300 Left = 1200 TabIndex = 8 Top = 1800 Width = 975 End Begin VB.CommandButton cmdNewGroup Caption = "&New" Height = 300 Left = 0 TabIndex = 7 Top = 1800 Width = 975 End Begin VB.ListBox lstGroups Height = 1620 Left = 0 TabIndex = 6 Top = 0 Width = 2175 End Begin VB.Label lblLabels BackColor = &H00C0C0C0& Caption = "Members:" Height = 255 Index = 2 Left = 120 TabIndex = 14 Top = 2160 Width = 2055 End End Begin VB.Label lblLabels Caption = "Owner:" Height = 255 Index = 3 Left = 2520 TabIndex = 27 Top = 2400 Width = 735 End Begin VB.Label lblLabels Caption = "Tables/Querys:" Height = 255 Index = 0 Left = 2520 TabIndex = 17 Top = 165 Width = 2055 End Begin VB.Line Line1 BorderWidth = 3 X1 = 2400 X2 = 2400 Y1 = 120 Y2 = 4440 End Attribute VB_Name = "frmGroupsUsers" Attribute VB_Creatable = False Attribute VB_Exposed = False Option Explicit Dim mbSettingUser As Integer Dim mbSettingOwner As Integer Dim mbSettingPerm As Integer Dim mbLoading As Integer Dim mobjCurrObject As Object 'currently selected table or query Private Sub cboOwners_Click() On Error GoTo COErr 'if we are setting thru code, just exit If mbSettingOwner = True Then Exit Sub If (mobjCurrObject.Permissions And dbSecWriteOwner) = dbSecWriteOwner Then 'try to set it mobjCurrObject.Owner = cboOwners.Text Else MsgBox "You do not have permission to change the Owner!", 48 Exit Sub End If Exit Sub COErr: ShowError Exit Sub End Sub Private Sub chkAdminister_Click() If mbSettingPerm = True Then Exit Sub If chkAdminister.Value = 1 Then 'set all of them chkReadDesign.Value = 1 chkModifyDesign.Value = 1 chkReadData.Value = 1 chkUpdateData.Value = 1 chkInsertData.Value = 1 chkDeleteData.Value = 1 End If End Sub Private Sub chkDeleteData_Click() If mbSettingPerm = True Then Exit Sub If chkDeleteData.Value = 0 Then 'unset others that need it chkAdminister.Value = 0 chkModifyDesign.Value = 0 Else chkReadDesign.Value = 1 chkReadData.Value = 1 End If End Sub Private Sub chkInsertData_Click() If mbSettingPerm = True Then Exit Sub If chkInsertData.Value = 0 Then 'unset others that need it chkAdminister.Value = 0 Else chkReadDesign.Value = 1 chkReadData.Value = 1 End If End Sub Private Sub chkModifyDesign_Click() If mbSettingPerm = True Then Exit Sub If chkModifyDesign.Value = 0 Then 'unset administer of them chkAdminister.Value = 0 Else chkReadDesign.Value = 1 chkReadData.Value = 1 chkInsertData.Value = 1 chkDeleteData.Value = 1 End If End Sub Private Sub chkReadData_Click() If mbSettingPerm = True Then Exit Sub If chkReadData.Value = 0 Then 'unset others that need it chkAdminister.Value = 0 chkModifyDesign.Value = 0 Else chkReadDesign.Value = 1 End If End Sub Private Sub chkReadDesign_Click() If mbSettingPerm = True Then Exit Sub If chkReadDesign.Value = 0 Then 'unset all of them chkAdminister.Value = 0 chkModifyDesign.Value = 0 chkReadData.Value = 0 chkUpdateData.Value = 0 chkInsertData.Value = 0 chkDeleteData.Value = 0 End If End Sub Private Sub chkUpdateData_Click() If mbSettingPerm = True Then Exit Sub If chkUpdateData.Value = 0 Then 'unset others that need it chkAdminister.Value = 0 chkModifyDesign.Value = 0 Else chkReadDesign.Value = 1 chkReadData.Value = 1 End If End Sub Private Sub cmdAssign_Click() SetPermissions True 'this will assign them End Sub Private Sub cmdClose_Click() Unload Me End Sub Private Sub cmdDeleteGroup_Click() On Error GoTo DGErr Dim i As Integer If lstGroups.ListIndex < 0 Then Beep MsgBox "No Group Selected!" Exit Sub End If If MsgBox("Delete '" & lstGroups.Text & "'?", gnMSGBOX_TYPE) <> gnMSGBOX_YES Then Exit Sub gwsMainWS.Groups.Delete lstGroups.Text i = lstGroups.ListIndex lstGroups.RemoveItem i lstUsersGroups.RemoveItem i If lstGroups.ListCount > 0 Then lstGroups.ListIndex = 0 Else 'need to unselect all users For i = 0 To lstGroupsUsers.ListCount - 1 lstGroupsUsers.Selected(i) = False Next End If Exit Sub DGErr: ShowError Exit Sub End Sub Private Sub cmdDeleteUser_Click() On Error GoTo DUErr Dim i As Integer If lstUsers.ListIndex < 0 Then Beep MsgBox "No User Selected!" Exit Sub End If If MsgBox("Delete '" & lstUsers.Text & "'?", gnMSGBOX_TYPE) <> gnMSGBOX_YES Then Exit Sub gwsMainWS.Users.Delete lstUsers.Text lstUsers.RemoveItem lstUsers.ListIndex If lstUsers.ListCount > 0 Then lstUsers.ListIndex = 0 Else 'need to unselect all groups For i = 0 To lstUsersGroups.ListCount - 1 lstUsersGroups.Selected(i) = False Next End If Exit Sub DUErr: ShowError Exit Sub End Sub Private Sub cmdNewGroup_Click() frmNewUserGroup.Caption = "New Group" frmNewUserGroup.Show vbModal End Sub Private Sub cmdNewUser_Click() frmNewUserGroup.Caption = "New User" frmNewUserGroup.Show vbModal End Sub Private Sub cmdPassword_Click() On Error GoTo CPErr If lstUsers.Text = gwsMainWS.UserName Then frmNewPassword.Show vbModal Else If MsgBox("Clear the Password for '" & lstUsers.Text & "'?", gnMSGBOX_TYPE) = gnMSGBOX_YES Then gwsMainWS.Users(lstUsers.Text).NewPassword gsNULL_STR, gsNULL_STR End If End If Exit Sub CPErr: ShowError Exit Sub End Sub Private Sub Form_Load() On Error GoTo FLErr Dim grp As GROUP Dim usr As User Dim i As Integer CenterMe Me, gnMDIFORM mbLoading = True 'add the groups and users For Each usr In gwsMainWS.Users lstUsers.AddItem usr.Name lstGroupsUsers.AddItem usr.Name cboOwners.AddItem usr.Name Next For Each grp In gwsMainWS.Groups lstGroups.AddItem grp.Name lstUsersGroups.AddItem grp.Name cboOwners.AddItem grp.Name Next 'set the 1st item if possible If lstUsers.ListCount > 0 Then lstUsers.ListIndex = 0 End If If lstGroups.ListCount > 0 Then lstGroups.ListIndex = 0 End If 'fill in the objects lists from the tables form GetTableList lstTablesQuerys, True, False, False mbLoading = False lstTablesQuerys.Selected(0) = True Screen.MousePointer = vbDefault Exit Sub FLErr: mbLoading = False ShowError Exit Sub End Sub Private Sub lstGroups_Click() On Error GoTo GSErr Dim i As Integer mbSettingUser = True For i = 0 To lstGroupsUsers.ListCount - 1 If IsMemberOf(lstGroups.Text, lstGroupsUsers.List(i)) Then lstGroupsUsers.Selected(i) = True Else lstGroupsUsers.Selected(i) = False End If Next mbSettingUser = False Exit Sub GSErr: ShowError mbSettingUser = False Exit Sub End Sub Private Sub lstGroups_MouseUp(Button As Integer, Shift As Integer, x As Single, Y As Single) If Button <> 2 Then Exit Sub If SetPropItem(lstGroups, Y) = False Then Exit Sub ShowProperties "Group", gwsMainWS.Groups(lstGroups.Text) End Sub Private Sub lstGroupsUsers_Click() On Error GoTo GUErr Dim usr As User If mbSettingUser = True Then Exit Sub If lstGroups.ListIndex < 0 Then Beep MsgBox "No Group Selected!" Exit Sub End If If lstGroupsUsers.Selected(lstGroupsUsers.ListIndex) = True Then 'add the user to the group Set usr = gwsMainWS.CreateUser(lstGroupsUsers.Text) gwsMainWS.Groups(lstGroups.Text).Users.Append usr gwsMainWS.Users(lstGroupsUsers.Text).Groups.Refresh Else 'remove the user from the group gwsMainWS.Groups(lstGroups.Text).Users.Delete lstGroupsUsers.Text gwsMainWS.Users(lstGroupsUsers.Text).Groups.Refresh End If Exit Sub GUErr: ShowError Exit Sub End Sub Private Sub lstTablesQuerys_Click() SetPermissions False End Sub Private Sub lstUsers_Click() On Error GoTo USErr Dim i As Integer mbSettingUser = True For i = 0 To lstUsersGroups.ListCount - 1 If IsMemberOf(lstUsersGroups.List(i), lstUsers.Text) Then lstUsersGroups.Selected(i) = True Else lstUsersGroups.Selected(i) = False End If Next mbSettingUser = False 'show permissions SetPermissions False Exit Sub USErr: ShowError mbSettingUser = False Exit Sub End Sub Private Function IsMemberOf(rsGrp As String, rsUsr As String) As Integer Dim usr As User Dim grp As GROUP Dim i As Integer Set usr = gwsMainWS.Users(rsUsr) For Each grp In usr.Groups If grp.Name = rsGrp Then IsMemberOf = True Exit Function End If Next IsMemberOf = False End Function Private Sub lstUsers_MouseUp(Button As Integer, Shift As Integer, x As Single, Y As Single) If Button <> 2 Then Exit Sub If SetPropItem(lstUsers, Y) = False Then Exit Sub ShowProperties "User", gwsMainWS.Users(lstUsers.Text) End Sub Private Sub lstUsersGroups_Click() On Error GoTo UGErr Dim grp As GROUP If mbSettingUser = True Then Exit Sub If lstUsers.ListIndex < 0 Then Beep MsgBox "No User Selected!" Exit Sub End If If lstUsersGroups.Selected(lstUsersGroups.ListIndex) = True Then 'add the group to the user Set grp = gwsMainWS.CreateGroup(lstUsersGroups.Text) gwsMainWS.Users(lstUsers.Text).Groups.Append grp gwsMainWS.Groups(lstUsersGroups.Text).Users.Refresh Else 'remove the group from the user gwsMainWS.Users(lstUsers.Text).Groups.Delete lstUsersGroups.Text gwsMainWS.Groups(lstUsersGroups.Text).Users.Refresh End If Exit Sub UGErr: ShowError Exit Sub End Sub Private Sub optGroups_Click() picUsers.Visible = False picGroups.Visible = True End Sub Private Sub optUsers_Click() picGroups.Visible = False picUsers.Visible = True End Sub Private Sub SetPermissions(rbAssign As Integer) On Error GoTo SPErr Dim lPermissions As Long Dim lPermissions2 As Long Dim bUncommon As Integer 'multiselected flag for common permissions Dim nCnt As Integer 'count of selected objects Dim sUserGroup As String Dim sObject As String Dim i As Integer mbSettingPerm = True If rbAssign = True Then 'determine what permissions are set and Or them together If chkReadDesign.Value = 0 Then lPermissions = 0 Else If chkAdminister.Value = 1 Then 'set them all lPermissions = dbSecFullAccess Or _ dbSecReadDef Or _ dbSecWriteDef Or _ dbSecRetrieveData Or _ dbSecReplaceData Or _ dbSecInsertData Or _ dbSecDeleteData Else 'set them one at a time lPermissions = dbSecReadDef If chkModifyDesign.Value = 1 Then lPermissions = lPermissions Or dbSecWriteDef End If If chkReadData.Value = 1 Then lPermissions = lPermissions Or dbSecRetrieveData End If If chkUpdateData.Value = 1 Then lPermissions = lPermissions Or dbSecReplaceData End If If chkInsertData.Value = 1 Then lPermissions = lPermissions Or dbSecInsertData End If If chkDeleteData.Value = 1 Then lPermissions = lPermissions Or dbSecDeleteData End If End If End If End If 'determine if it's a user or a group If optUsers.Value = True Then 'users sUserGroup = lstUsers.Text Else 'groups sUserGroup = lstGroups.Text End If 'set or get the permissions If lstTablesQuerys.ListIndex = -1 Then If mbLoading = False Then 'don't issue error on form load Beep MsgBox "No Object Selected!" End If Exit Sub End If 'walk the object list and process the selected objects For i = 0 To lstTablesQuerys.ListCount - 1 If lstTablesQuerys.Selected(i) = True Then nCnt = nCnt + 1 If lstTablesQuerys.ListIndex = 0 Then 'must be <New Object> gdbCurrentDB.Containers("Tables").UserName = sUserGroup If rbAssign = False Then lPermissions = gdbCurrentDB.Containers("Tables").Permissions Else gdbCurrentDB.Containers("Tables").Permissions = lPermissions End If ShowOwner gdbCurrentDB.Containers("Tables") Set mobjCurrObject = gdbCurrentDB.Containers("Tables") Else sObject = StripConnect(lstTablesQuerys.List(i)) 'a table ot query was selected gdbCurrentDB.Containers("Tables").Documents(sObject).UserName = sUserGroup If rbAssign = False Then lPermissions = gdbCurrentDB.Containers("Tables").Documents(sObject).Permissions Else gdbCurrentDB.Containers("Tables").Documents(sObject).Permissions = lPermissions End If ShowOwner gdbCurrentDB.Containers("Tables").Documents(sObject) Set mobjCurrObject = gdbCurrentDB.Containers("Tables").Documents(sObject) End If If nCnt > 1 Then 'if there is more than 1, they need to match or we set the flag If lPermissions <> lPermissions2 Then bUncommon = True End If End If 'store it for the next time through lPermissions2 = lPermissions End If Next If rbAssign = False Then If bUncommon = True Then 'there was some mismatch so they need to be greyed chkReadDesign.Value = 2 chkModifyDesign.Value = 2 chkAdminister.Value = 2 chkReadData.Value = 2 chkUpdateData.Value = 2 chkInsertData.Value = 2 chkDeleteData.Value = 2 Else 'there was either only one or they were all the same 'so we need to set them appropriately If (lPermissions And dbSecReadDef) = dbSecReadDef Then chkReadDesign.Value = 1 Else chkReadDesign.Value = 0 End If If (lPermissions And dbSecWriteDef) = dbSecWriteDef Then chkModifyDesign.Value = 1 Else chkModifyDesign.Value = 0 End If If (lPermissions And dbSecFullAccess) = dbSecFullAccess Then chkAdminister.Value = 1 Else chkAdminister.Value = 0 End If If (lPermissions And dbSecRetrieveData) = dbSecRetrieveData Then chkReadData.Value = 1 Else chkReadData.Value = 0 End If If (lPermissions And dbSecReplaceData) = dbSecReplaceData Then chkUpdateData.Value = 1 Else chkUpdateData.Value = 0 End If If (lPermissions And dbSecInsertData) = dbSecInsertData Then chkInsertData.Value = 1 Else chkInsertData.Value = 0 End If If (lPermissions And dbSecDeleteData) = dbSecDeleteData Then chkDeleteData.Value = 1 Else chkDeleteData.Value = 0 End If End If End If mbSettingPerm = False Exit Sub SPErr: mbSettingPerm = False ShowError Exit Sub End Sub Private Sub ShowOwner(vObj As Object) On Error GoTo SOErr Dim i As Integer For i = 0 To cboOwners.ListCount - 1 If cboOwners.List(i) = vObj.Owner Then mbSettingOwner = True cboOwners.ListIndex = i mbSettingOwner = False Exit For End If Next Exit Sub SOErr: mbSettingOwner = True cboOwners.ListIndex = -1 mbSettingOwner = False ShowError Exit Sub End Sub