
'----------------------------------------------------------------
' Custom Project 17-1
' No code in this project.
' Please follow the instructions in the book.
'----------------------------------------------------------------


'----------------------------------------------------------------
' Hands-On 17-1
'----------------------------------------------------------------

Sub Create_UserAndGroup_ADO()
    Dim cat As ADOX.Catalog
    Dim conn As ADODB.Connection
    Dim strDB As String
    Dim strSysDB As String
    Dim strGrpName1 As String
    Dim strGrpName2 As String
    Dim strUsrName As String

    On Error GoTo ErrorHandler

    strDB = "C:\Acc07_ByExample\SpecialDb.mdb"
    strSysDB = "C:\Acc07_ByExample\Security1.mdw"
    strGrpName1 = "Masters"
    strGrpName2 = "Elite"
    strUsrName = "PowerUser"
    ' open connection to the database
    ' using the specified system database
    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") = "chapter17"
            .Open strDB
        End With

    ' Open the catalog
    Set cat = New ADOX.Catalog
    With cat
        .ActiveConnection = conn
        'create group accounts
        .Groups.Append strGrpName1
        .Groups.Append strGrpName2
        Debug.Print "Successfully created group accounts."
        'create a user account
        .Users.Append strUsrName, "star"
        Debug.Print "Successfully created user account."
        'Add user to the group
        .Users(strUsrName).Groups.Append strGrpName2
        Debug.Print strUsrName & " is a member of the " & _
            strGrpName2 & " group account."
    End With
 
ExitHere:
    Set cat = Nothing
    conn.Close
    Set conn = Nothing
    Exit Sub
ErrorHandler:
    MsgBox Err.Description
    Resume ExitHere
End Sub


'----------------------------------------------------------------
' Hands-On 17-2
'----------------------------------------------------------------

Sub Delete_UserAndGroup(UserName As String, _
                        GroupName As String)
    Dim cat As ADOX.Catalog
    Dim conn As ADODB.Connection
    Dim strDB As String
    Dim strSysDB As String

    On Error GoTo ErrorHandler

    strDB = "C:\Acc07_ByExample\SpecialDb.mdb"
    strSysDB = "C:\Acc07_ByExample\Security1.mdw"

    ' Open connection to the database using
    ' the specified system database
    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") = "chapter17"
            .Open strDB
        End With

    ' Open the catalog
    Set cat = New ADOX.Catalog
    With cat
        .ActiveConnection = conn
        ' Delete user
        .Users.Delete UserName
        ' Delete group
        .Groups.Delete GroupName
    End With
    
ExitHere:
    Set cat = Nothing
    conn.Close
    Set conn = Nothing
    Exit Sub
ErrorHandler:
    MsgBox Err.Description
    Resume ExitHere
End Sub


'----------------------------------------------------------------
' Hands-On 17-3
'----------------------------------------------------------------

Sub List_GroupsAndUsers_ADO()
    Dim conn As ADODB.Connection
    Dim cat As ADOX.Catalog
    Dim grp As New ADOX.Group
    Dim usr As New ADOX.User
    Dim strDB As String
    Dim strSysDB As String

    strDB = "C:\Acc07_ByExample\SpecialDb.mdb"
    strSysDB = "C:\Acc07_ByExample\Security1.mdw"

    ' Open connection to the database using
    ' the specified system database
    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") = "chapter17"
            .Open strDB
        End With

    ' Open the catalog
    Set cat = New ADOX.Catalog
    cat.ActiveConnection = conn
    'list group and user accounts
    For Each grp In cat.Groups
        Debug.Print "Group: " & grp.Name
    Next
    
    For Each usr In cat.Users
        Debug.Print "User: " & usr.Name
    Next

    Set cat = Nothing
    conn.Close
    Set conn = Nothing

    MsgBox "Groups and users are listed in the Immediate Window."
End Sub


'----------------------------------------------------------------
' Hands-On 17-4
'----------------------------------------------------------------

Sub List_UsersInGroups()
    Dim conn As ADODB.Connection
    Dim cat As ADOX.Catalog
    Dim grp As New ADOX.Group
    Dim usr As New ADOX.User
    Dim strDB As String
    Dim strSysDB As String

    strDB = "C:\Acc07_ByExample\SpecialDb.mdb"
    strSysDB = "C:\Acc07_ByExample\Security1.mdw"

    ' Open connection to the database using
    ' the specified system database
    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") = "chapter17"
            .Open strDB
        End With

    ' Open the catalog
    Set cat = New ADOX.Catalog
    cat.ActiveConnection = conn
    For Each grp In cat.Groups
        Debug.Print "Group: " & grp.Name
        If cat.Groups(grp.Name).Users.Count = 0 Then
            Debug.Print vbTab & "There are no users in the " & _
                grp & " group."
        End If
        For Each usr In cat.Groups(grp.Name).Users
            Debug.Print vbTab & "User: " & usr.Name
        Next usr
    Next grp

    Set cat = Nothing
    conn.Close
    Set conn = Nothing
    MsgBox "Groups and Users are listed in the Immediate Window."
End Sub


'----------------------------------------------------------------
' Hands-On 17-5
'----------------------------------------------------------------

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 = "C:\Acc07_ByExample\SpecialDb.mdb"
    strSysDB = "C:\Acc07_ByExample\Security1.mdw"
    strObjName = "Customers"

    ' Open connection to the database using
    ' the specified system database
    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") = "chapter17"
            .Open strDB
        End With

    ' Open the catalog
    Set cat = New ADOX.Catalog
    cat.ActiveConnection = conn

    ' Display the name of the table owner
    MsgBox "The owner of the " & strObjName & _
           " table is " & vbCr _
    & cat.GetObjectOwner(strObjName, adPermObjTable) & "."

    Set cat = Nothing
    conn.Close
    Set conn = Nothing
End Sub


'----------------------------------------------------------------
' Hands-On 17-6
'----------------------------------------------------------------

Sub Set_UserObjectPermissions()
    Dim conn As ADODB.Connection
    Dim cat As ADOX.Catalog
    Dim strDB As String
    Dim strSysDB As String
    
    On Error GoTo ErrorHandler

    strDB = "C:\Acc07_ByExample\SpecialDb.mdb"
    strSysDB = "C:\Acc07_ByExample\Security1.mdw"

    ' Open connection to the database using
    ' the specified system database
    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") = "chapter17"
            .Open strDB
        End With

    ' Open the catalog
    Set cat = New ADOX.Catalog
    cat.ActiveConnection = conn
    ' add a user account
    cat.Users.Append "PowerUser", "star"

    ' Set permissions for PowerUser on the Customers table
    cat.Users("PowerUser").SetPermissions "Customers", _
        adPermObjTable, _
        adAccessSet, _
        adRightRead Or _
        adRightInsert Or _
        adRightUpdate Or _
        adRightDelete
    MsgBox "Read, Insert, Update and Delete permissions " & _
        vbCrLf & " were set on Customers table " & _
        "for PowerUser."
ExitHere:
    Set cat = Nothing
    conn.Close
    Set conn = Nothing
    Exit Sub
ErrorHandler:
    If Err.Number = -2147467259 Then
        MsgBox "PowerUser user already exists."
        Resume Next
    Else
        MsgBox Err.Description
        Resume ExitHere
    End If
End Sub


'----------------------------------------------------------------
' Hands-On 17-7
'----------------------------------------------------------------

Sub Set_UserDbPermissions_ADO()
    Dim conn As ADODB.Connection
    Dim cat As ADOX.Catalog
    Dim strDB As String
    Dim strSysDB As String

    On Error GoTo ErrorHandler

    strDB = "C:\Acc07_ByExample\SpecialDb.mdb"
    strSysDB = "C:\Acc07_ByExample\Security1.mdw"

    ' Open connection to the database using
    ' the specified system database
    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") = "chapter17"
            .Open strDB
        End With

    ' Open the catalog
    Set cat = New ADOX.Catalog
    cat.ActiveConnection = conn

    ' add a user account
    cat.Users.Append "PowerUser", "star"

    ' Set permissions for PowerUser
    cat.Users("PowerUser").SetPermissions "", adPermObjDatabase, _
      adAccessSet, adRightExclusive
    MsgBox "PowerUser has been granted permission to " & vbCrLf & _
          "open the database exclusively."
ExitHere:
    Set cat = Nothing
    conn.Close
    Set conn = Nothing
    Exit Sub
ErrorHandler:
    If Err.Number = -2147467259 Then
        ' because PowerUser user already exists
        ' we ignore this statement
        Resume Next
    Else
        MsgBox Err.Description
        Resume ExitHere
    End If
End Sub


'----------------------------------------------------------------
' Hands-On 17-8
'----------------------------------------------------------------

Sub Set_UserContainerPermissions_ADO()
    Dim conn As ADODB.Connection
    Dim cat As ADOX.Catalog
    Dim strDB As String
    Dim strSysDB As String

    On Error GoTo ErrorHandler

    strDB = "C:\Acc07_ByExample\SpecialDb.mdb"
    strSysDB = "C:\Acc07_ByExample\Security1.mdw"

    ' Open connection to the database using
    ' the specified system database
    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") = "chapter17"
            .Open strDB
        End With

    ' Open the catalog
    Set cat = New ADOX.Catalog
    cat.ActiveConnection = conn

    ' add a user account
    cat.Users.Append "PowerUser", "star"

    ' Set permissions for PowerUser on the Tables Container
    cat.Users("PowerUser").SetPermissions Null, _
        adPermObjTable, _
        adAccessSet, _
        adRightRead Or _
        adRightInsert Or _
        adRightUpdate Or _
        adRightDelete, adInheritNone
    MsgBox "You have successfully granted permissions " & vbCrLf & _
            "to PowerUser on the Tables Container."
ExitHere:
    Set cat = Nothing
    conn.Close
    Set conn = Nothing
    Exit Sub
ErrorHandler:
    If Err.Number = -2147467259 Then
        ' because PowerUser user already exists
        ' we ignore this statement
        Resume Next
    Else
        MsgBox Err.Description
        Resume ExitHere
    End If
End Sub


'----------------------------------------------------------------
' Hands-On 17-9
'----------------------------------------------------------------

Sub GetObjectPermissions_ADO(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 ErrorHandler

    strDB = "C:\Acc07_ByExample\SpecialDb.mdb"
    strSysDB = "C:\Acc07_ByExample\Security1.mdw"

    ' Open connection to the database using
    ' the specified system database
    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") = "chapter17"
            .Open strDB
        End With

    ' Open the catalog
    Set cat = New ADOX.Catalog
    cat.ActiveConnection = conn

    ' add a user account
    cat.Users.Append "PowerUser", "star"

    listPerms = cat.Users(strUserName) _
        .GetPermissions(varObjName, lngObjType)
    Debug.Print listPerms

    If (listPerms And ADOX.RightsEnum.adRightCreate) = adRightCreate Then
        strPermsTypes = strPermsTypes & "adRightCreate" & vbCr
    End If
    If (listPerms And RightsEnum.adRightRead) = adRightRead Then
        strPermsTypes = strPermsTypes & "adRightRead" & vbCr
    End If
    If (listPerms And RightsEnum.adRightUpdate) = adRightUpdate Then
        strPermsTypes = strPermsTypes & "adRightUpdate" & vbCr
    End If
    If (listPerms And RightsEnum.adRightDelete) = adRightDelete Then
        strPermsTypes = strPermsTypes & "adRightDelete" & vbCr
    End If
    If (listPerms And RightsEnum.adRightInsert) = adRightInsert Then
        strPermsTypes = strPermsTypes & "adRightInsert" & vbCr
    End If
    If (listPerms And RightsEnum.adRightReadDesign) = adRightReadDesign Then
        strPermsTypes = strPermsTypes & "adRightReadDesign" & vbCr
    End If

    Debug.Print strPermsTypes
    MsgBox "Permissions are listed in the Immediate Window."
ExitHere:
    Set cat = Nothing
    conn.Close
    Set conn = Nothing
    Exit Sub
ErrorHandler:
    If Err.Number = -2147467259 Then
        ' because PowerUser user already exists
        ' we ignore this statement
        Resume Next
    Else
        MsgBox Err.Description
        Resume ExitHere
    End If
End Sub


'----------------------------------------------------------------
' Hands-On 17-10
'----------------------------------------------------------------

Option Compare Database
Option Explicit

Sub Change_DBPassword()
    Dim jetEng As JRO.JetEngine
    Dim strCompactFrom As String
    Dim strCompactTo As String
    Dim strPath As String

    On Error GoTo ErrHandler
    strPath = CurrentProject.Path & "\"

    strCompactFrom = "PasswordTest.mdb"
    strCompactTo = "PasswordTest_Compact.mdb"

    Set jetEng = New JRO.JetEngine
    ' Compact the database specifying the new database password
    jetEng.CompactDatabase "Data Source=" & strPath & strCompactFrom & ";", _
                           "Data Source=" & strPath & strCompactTo & ";" & _
                           "Jet OLEDB:Database Password=welcome;"

ExitHere:
    Set jetEng = Nothing
    Exit Sub
ErrHandler:
    If Err.Number = -2147217897 Then
        Kill strPath & strCompactTo
        Resume
    Else
        MsgBox Err.Number & ": " & Err.Description
        Resume ExitHere
    End If
End Sub


'----------------------------------------------------------------
' Hands-On 17-11
'----------------------------------------------------------------

Sub Set_DBPassword_DAO()
    Dim db As DAO.Database
    Dim strDB As String

    strDB = CurrentProject.Path & "\Chap01.accdb"
    
    Set db = OpenDatabase(strDB, True)
    
    
    db.NewPassword "", "chapter1"
    db.Close
    Set db = Nothing
    
End Sub


'----------------------------------------------------------------
' Code on page 469
'----------------------------------------------------------------

Sub Unset_DBPassword_DAO()
    Dim db As DAO.Database
    Dim strDB As String

    strDB = CurrentProject.Path & "\Chap01.accdb"
    Set db = OpenDatabase(strDB, True, False, ";pwd=chapter1")
    
    db.NewPassword "chapter1", ""
    db.Close
    Set db = Nothing
End Sub


'----------------------------------------------------------------
' Hands-On 17-12
'----------------------------------------------------------------

Sub Change_UserPassword_ADO()
    Dim cat As ADOX.Catalog
    Dim strDB As String
    Dim strSysDB As String

    On Error GoTo ErrorHandler

    strDB = CurrentProject.Path & "\AdminPwd.mdb"
    ' change the path to use the default workgroup information file
    ' on your computer
    strSysDB = "C:\Documents and Settings\Julitta\" & _
               "Application Data\Microsoft\Access\System.mdw"

    'strSysDB = "C:\Acc07_ByExample\Security1.mdw"

    ' Open the catalog, specifying the system database to use
    Set cat = New ADOX.Catalog
    With cat
        .ActiveConnection = "Provider='Microsoft.Jet.OLEDB.4.0';" & _
                            "Data Source='" & strDB & "';" & _
                            "Jet OLEDB:System Database='" & strSysDB & "';" & _
                            "User Id=Admin;Password=;"

        ' Change the password for the Admin user
        .Users("Admin").ChangePassword "", "secret"
    End With

ExitHere:
    Set cat = Nothing
    Exit Sub
ErrorHandler:
    MsgBox Err.Description
    GoTo ExitHere
End Sub


'----------------------------------------------------------------
' Hands-On 17-13
'----------------------------------------------------------------

Sub EncryptDb()
    Dim jetEng As JRO.JetEngine
    Dim strCompactFrom As String
    Dim strCompactTo As String
    Dim strSource As String
    Dim strDest As String
    Dim strSysDB As String

    strCompactFrom = CurrentProject.Path & "\SpecialDb.mdb"
    strCompactTo = CurrentProject.Path & "\SpecialDb_Enc.mdb"
    strSysDB = CurrentProject.Path & "\Security1.mdw"
    
    On Error GoTo HandleErr

    ' Use the CompactDatabase method to create
    ' a new, encrypted version of the database
    Set jetEng = New JRO.JetEngine
                      
    strSource = "Data Source=" & strCompactFrom & ";" & _
        "Jet OLEDB:System Database=" & strSysDB & ";" & _
        "User ID=Developer" & ";" & _
        "Password=chapter17"
    
    strDest = "Data Source=" & strCompactTo & ";" & _
                       "Jet OLEDB:Engine Type=5;" & _
                    "Jet OLEDB:Encrypt Database=True"
    
    jetEng.CompactDatabase strSource, strDest
    
ExitHere:
    Set jetEng = Nothing
    Exit Sub
HandleErr:
    MsgBox Err.Number & ": " & Err.Description
    Resume ExitHere
End Sub

