Attribute VB_Name = "basSecurity_wrkgrp_generic"
'*******************************************************************************
' Project   : Generic Security for wrkgrp file.
' Module    : basSecurity_wrkgrp
' DateTime  : 10/28/2003 11:23
' Author    : Bill Mosca
'             Copyright © 2003 Bill Mosca
' Purpose   : Handles all Inserts, edits, deletes of wrkgrp file.
' Requires  : ADO Ext. Library for DDL and Security
'             ADO Library
' Index     :(Updated on 11/20/2008)
  ' BuildUserTable - Creates tblUsers
  ' VerifyUserID - Determine if CurrentUser is same as NT Login ID.
  ' EnvironInfo - Get NT Environment Info for either User Domain
  ' GetUserGroups - Get latest list of User Groups, excluding any if
  ' ChangePassword - Change password of existing user
  ' GenR8PWD - Generate random password.
  ' ChangeWrkGrp - Change user's workgroup.
  ' AddUser - Add new user to WrkGrp file and set security level.
  ' DeleteUser - Delete user from workgroup and tblUsers.
  ' SyncUsersWithTable - Keep tblUsers the same as wrkgrp file.
  ' UserExists - Find out if strUserID is a real user ID.
  ' ReadSecGrp - Get CurrentUser's User Group
  ' GetMyPermissions - Get user permissions for an object. Allows code to stop error
  ' ListUsers - Development use only.
  ' GetUserInfo_Script - Get User and computer info using Scripting DLL.
  ' EnvironID - Use Environ to get User ID
  ' IsADSMember - Test name for Active Directory Member
  ' ToggleDBWindow - Show/Hide DBWindow.
'*******************************************************************************

Option Compare Database
Option Explicit

Public Enum ObjectProp
    USER_NAME
    PC_NAME
    DOMAIN_NAME
End Enum

Public Sub BuildUserTable()
'Purpose  : Creates tblUsers
'DateTime : 11/20/2003 09:00
'Author   : Bill Mosca
'Requires : ADO Library
    Dim cnn As ADODB.Connection
    Dim strSQL As String

    On Error Resume Next

    Set cnn = CurrentProject.Connection
    strSQL = "CREATE TABLE [tblUsers] " & _
            "( " & _
            "[UserID]    varchar(20) PRIMARY KEY, " & _
            "[NameLast]  varchar(30) NULL, " & _
            "[NameFirst] varchar(30) NULL, " & _
            "[EmailAddr] varchar(100) NULL, " & _
            "[Phone]     varchar(24) NULL, " & _
            "[UserGroup] varchar(20) NULL, " & _
            "[PWD_Changed] bit DEFAULT 0, " & _
            "[CreateDate] datetime NULL, " & _
            "[Creator]    varchar(20) " & _
            ")"
    cnn.Execute strSQL
    If Err.Number = -2147217900 Then
        Err.Clear
        If MsgBox("Table already exists. Overwrite it?", _
                vbYesNo + vbInformation) = vbYes Then
            cnn.Execute "DROP TABLE tblUsers"
            Call BuildUserTable
        End If
    ElseIf Err.Number <> 0 Then GoTo err_PROC
    End If


exit_PROC:
    On Error Resume Next
    Application.RefreshDatabaseWindow
    Set cnn = Nothing
    Exit Sub

err_PROC:
    Dim strErrMsg As String
    Dim lngErrIconBtn As Long

    strErrMsg = "Error " & Err.Number & " (" & Err.Description & ") " _
            & "occurred in procedure VerifyUserID of " _
            & "VBA Document basSecurity_wrkgrp"
    lngErrIconBtn = vbOKOnly + vbInformation

    '    If strErrMsg <> "" Then MsgBox strErrMsg, lngErrIconBtn, "Error"

    Resume exit_PROC


End Sub
Public Function VerifyUserID() As Boolean
'Purpose  : Determine if CurrentUser is same as NT Login ID.
'           DBA and developers should be the only persons allowed
'           to log in under another user's ID for testing.
'DateTime : 8/9/2007 11:23
'Author   : Bill Mosca
    Dim strNT As String
    Dim strDomain As String
    Dim strUserID_AD As String
    Dim strULSGroup As String
    
    On Error GoTo err_PROC
    
    strNT = GetUserInfo_Script(ObjectProp.USER_NAME)
    
    'Skip verification if this is an Admins user. Admins may be logging
    'in on someone else's NT login.
    strULSGroup = ReadSecGrp(CurrentUser)
    If strULSGroup = "Admins" _
      Or strULSGroup = "DBA" Then
        VerifyUserID = True
        GoTo exit_PROC
    End If
    
    strDomain = GetUserInfo_Script(ObjectProp.DOMAIN_NAME)
    strUserID_AD = _
        DLookup("UserID_AD", "tblUsers", "UserID = '" & CurrentUser & "'")
    If StrComp(strUserID_AD, strDomain & "\" & strNT, vbTextCompare) = 0 Then
        VerifyUserID = True
    End If
exit_PROC:
    On Error Resume Next
    Exit Function

err_PROC:
    Dim strErrMsg As String
    Dim lngErrIconBtn As Long
    
    strErrMsg = "Error " & Err.Number & " (" & Err.Description & ") " _
        & "occurred in procedure VerifyUserID of " _
        & "VBA Document basSecurity_wrkgrp"
    lngErrIconBtn = vbOKOnly + vbInformation

    MsgBox strErrMsg, lngErrIconBtn, "Error"
    
    Resume exit_PROC

    
End Function

Public Function EnvironInfo(Optional strIndex = "COMPUTERNAME") As String
'Purpose  : Get NT Environment Info for either User Domain
'           or User Name. Upper Case is needed for some operating systems.
'DateTime : 10/12/2004 08:06
'Author   : Bill Mosca
'Parameter: Any of the environment strings such as
'           "COMPUTERNAME", "USERNAME", "USERDOMAIN".
    
    EnvironInfo = Environ(UCase(strIndex))
        
End Function

Public Function GetUserGroups(ParamArray aryExclude() As Variant) As String
'Purpose  : Get latest list of User Groups, excluding any if
'           CurrentUser not Tech Support.
'DateTime : 10/24/2003 10:23
'Author   : Bill Mosca
    Dim cat As New ADOX.Catalog
    Dim cnn As ADODB.Connection
    Dim grp As ADOX.Group
    Dim strList As String
    Dim x As Integer
    
    On Error GoTo err_PROC

    ' Open the catalog
    Set cnn = CurrentProject.Connection
    cat.ActiveConnection = cnn
    'Get each user group name
    For Each grp In cat.Groups
        'Skip "Users"
        If grp.Name = "Users" Then GoTo LoopMe
        'Search each group in array. If matches group in wrkgrp
        ' skip it.
        For x = 0 To UBound(aryExclude)
            If grp.Name = aryExclude(x) Then
                GoTo LoopMe
            Else
                
            End If
        Next
        'Add name to list.
        strList = strList & grp.Name & ";"
LoopMe:
    Next
    
    'Trim off last semicolon.
    If Right(strList, 1) = ";" Then
        strList = Left(strList, Len(strList) - 1)
    End If
    
    GetUserGroups = strList
    

exit_PROC:
    On Error Resume Next
    Set cat = Nothing
    cnn.Close
    Set cnn = Nothing
    Exit Function

err_PROC:
    Dim strErrMsg As String
    Dim lngErrIconBtn As Long
    
    strErrMsg = "Error " & Err.Number & " (" & Err.Description & ") " _
        & "occurred in procedure GetUserGroups of " _
        & "VBA Document basSecurity_wrkgrp"
    lngErrIconBtn = vbOKOnly + vbInformation

    MsgBox strErrMsg, lngErrIconBtn, "Error"
    
    Resume exit_PROC

End Function

Public Function ChangePassword(ByVal strUserID As String, ByVal strNewPWD As String, _
    ByVal strOldPWD As String) As Boolean
'Purpose  : Change password of existing user
'DateTime : 10/28/2003 08:16
'Author   : Bill Mosca
    
    Dim cat As New ADOX.Catalog
    Dim cnn As ADODB.Connection
    
    On Error GoTo err_ChangePassword
    

    Set cnn = CurrentProject.Connection
    cat.ActiveConnection = cnn
        
            
   ' Change the password for the user
    cat.Users(strUserID).ChangePassword strOldPWD, strNewPWD
   
    'Flag user as having changed password.
    cnn.Execute "UPDATE tblUsers SET PWD_Changed=-1 " _
        & "WHERE UserID='" & strUserID & "'"
    
    ChangePassword = True

exit_ChangePassword:
    On Error Resume Next
    Set cat = Nothing
    Set cnn = Nothing
    Exit Function

err_ChangePassword:
    Dim strErrMsg As String
    Dim lngErrIconBtn As Long
    
    strErrMsg = "Error " & Err.Number & " (" & Err.Description & ") " _
        & "occurred in procedure ChangePassword of " _
        & "VBA Document basSecurity_wrkgrp"
    lngErrIconBtn = vbOKOnly + vbInformation
    
    MsgBox strErrMsg, lngErrIconBtn, "Error"
    
    Resume exit_ChangePassword

End Function

Public Function GenR8PWD(lngLen As Long) As String
'Purpose  : Generate random password.
'DateTime : 12/4/2007 07:40
'Author   : Bill Mosca
'Reference: none
    Dim x As Long
    Dim strPWD As String

    For x = 1 To lngLen
        Randomize
        'Characters 35 to 122
        strPWD = strPWD & Chr(Int((122 - 35 + 1) * Rnd) + 35)
    Next

    GenR8PWD = strPWD

End Function

Public Sub ChangeWrkGrp(strUserID As String, strNewGroup As String)
'Purpose  : Change user's workgroup.
'DateTime : 10/31/2003 12:32
'Author   : Bill Mosca
    Dim cat As New ADOX.Catalog
    Dim cnn As ADODB.Connection
    Dim strGroup As String
    
    On Error GoTo err_ChangeWrkGrp
    
    Set cnn = CurrentProject.Connection
    cat.ActiveConnection = cnn
    
    'Get User's User Group
    strGroup = ReadSecGrp(strUserID)
    
    'delete user from group
    cat.Users(strUserID).Groups.Delete strGroup
    
    'Add User to another user group
    cat.Users(strUserID).Groups.Append strNewGroup

exit_ChangeWrkGrp:
    On Error Resume Next
    Set cat = Nothing
    cnn.Close
    Set cnn = Nothing
    Exit Sub

err_ChangeWrkGrp:
    Dim strErrMsg As String
    Dim lngErrIconBtn As Long

    strErrMsg = "Error " & Err.Number & " (" & Err.Description & ") " _
        & "occurred in procedure ChangePassword of " _
        & "VBA Document basSecurity_wrkgrp"
    lngErrIconBtn = vbOKOnly + vbInformation
    
    MsgBox strErrMsg, lngErrIconBtn, "Error"
    
    Resume exit_ChangeWrkGrp

End Sub

Public Function AddUser(ByVal strUserID As String, ByVal strPWD As String, _
  ByVal strUserGroup As String) As Boolean
'Purpose  : Add new user to WrkGrp file and set security level.
'DateTime : 10/28/2003 07:59
'Author   : Bill Mosca
    Dim cat As New ADOX.Catalog
    Dim cnn As ADODB.Connection

    On Error GoTo err_AddUser
    
    Set cnn = CurrentProject.Connection
    cat.ActiveConnection = cnn
    
    cat.Users.Append strUserID, strPWD

    'Password not going into wrkgrp file - reason unknown.
    ' workaround: call ChangePassword to set password.
    Call ChangePassword(strUserID, strPWD, "")
    
    'Every member must be member of "Users" group or he will not
    '  be able to open Access.
    cat.Users(strUserID).Groups.Append "Users"
    cat.Users(strUserID).Groups.Append strUserGroup
    AddUser = True
    
exit_AddUser:
    On Error Resume Next
    Set cat = Nothing
    cnn.Close
    Set cnn = Nothing
    Exit Function

err_AddUser:
    Select Case Err.Number
        Case -2147467259
            MsgBox "The UserID " & strUserID & " is already a member." _
                & " Please enter a new UserID or call the Help Desk for assistance.", _
                vbExclamation, "Existing User"
        Case Else
    Dim strErrMsg As String
    Dim lngErrIconBtn As Long

    strErrMsg = "Error " & Err.Number & " (" & Err.Description & ") " _
        & "occurred in procedure ChangePassword of " _
        & "VBA Document basSecurity_wrkgrp"
    lngErrIconBtn = vbOKOnly + vbInformation
    
    MsgBox strErrMsg, lngErrIconBtn, "Error"
    End Select
    
    Resume exit_AddUser

End Function

Public Sub DeleteUser(strUserID As String)
'Purpose  : Delete user from workgroup and tblUsers.
'DateTime : 10/29/2003 15:15
'Author   : Bill Mosca
    Dim cat As New ADOX.Catalog
    Dim cnn As ADODB.Connection
    Dim strSQL As String
    
    On Error GoTo err_PROC

    
    Set cnn = CurrentProject.Connection
    cat.ActiveConnection = cnn
    'Drop user.
    cat.Users.Delete strUserID
    
    'Delete from tblUsers.
    strSQL = "DELETE  FROM tblUsers " _
        & "WHERE UserID=" & Chr(34) & strUserID & Chr(34)
    cnn.Execute strSQL
    
    'Delete from tblUserCostCenters.
    strSQL = "DELETE  FROM tblUserCostCenters " _
        & "WHERE UserID=" & Chr(34) & strUserID & Chr(34)
    cnn.Execute strSQL
    
    'Delete from tblUserCCGroups.
    strSQL = "DELETE  FROM tblUserCCGroups " _
        & "WHERE UserID=" & Chr(34) & strUserID & Chr(34)
    cnn.Execute strSQL

exit_PROC:
    On Error Resume Next
    Set cat = Nothing
    Set cnn = Nothing
    Exit Sub

err_PROC:
    Dim strErrMsg As String
    Dim lngErrIconBtn As Long
    
    strErrMsg = "Error " & Err.Number & " (" & Err.Description & ") " _
        & "occurred in procedure VerifyUserID of " _
        & "VBA Document basSecurity_wrkgrp"
    lngErrIconBtn = vbOKOnly + vbInformation

    MsgBox strErrMsg, lngErrIconBtn, "Error"
    
    Resume exit_PROC



End Sub

Public Sub SyncUsersWithTable()
'Purpose  : Keep tblUsers the same as wrkgrp file.
'DateTime : 11/12/2003 10:47
'Author   : Bill Mosca
    Dim cat As New ADOX.Catalog
    Dim cnn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim strSQL As String
    Dim strUserID As String
    Dim usr As ADOX.User
    
    On Error GoTo err_SyncUsersWithTable

    Set cnn = CurrentProject.Connection
    cat.ActiveConnection = cnn
    Set rs = New ADODB.Recordset
    strSQL = "SELECT UserID from tblUsers"
    rs.Open strSQL, cnn, adOpenKeyset, adLockOptimistic
    
    With rs
        Do While Not .EOF
            strUserID = .Fields(0)
            For Each usr In cat.Users
                If usr.Name = strUserID Then
                    GoTo LoopMe
                End If
            Next
            
            'If UserID not found in Users Then delete it.
            .Delete adAffectCurrent
            .Update
                
LoopMe:
            .MoveNext
        Loop
    End With
    

exit_SyncUsersWithTable:
    On Error Resume Next
    Set cat = Nothing
    Set cnn = Nothing
    Set rs = Nothing
    Exit Sub

err_SyncUsersWithTable:
    Dim strErrMsg As String
    Dim lngErrIconBtn As Long
    
    strErrMsg = "Error " & Err.Number & " (" & Err.Description & ") " _
        & "occurred in procedure VerifyUserID of " _
        & "VBA Document basSecurity_wrkgrp"
    lngErrIconBtn = vbOKOnly + vbInformation

    MsgBox strErrMsg, lngErrIconBtn, "Error"
    
    Resume exit_SyncUsersWithTable

    
End Sub

Public Function UserExists(strUserID As String) As Boolean
'Purpose  : Find out if strUserID is a real user ID.
'DateTime : 11/21/2003 12:56
'Author   : Bill Mosca
    Dim cnn As ADODB.Connection
    Dim cat As New ADOX.Catalog
    Dim usr As ADOX.User
    
    On Error GoTo err_UserExists

    Set cnn = CurrentProject.Connection
    cat.ActiveConnection = cnn
    
    For Each usr In cat.Users
        If usr.Name = strUserID Then
            UserExists = True
            Exit For
        End If
    Next

exit_UserExists:
    On Error Resume Next
    Set cat = Nothing
    Set cnn = Nothing
    Exit Function

err_UserExists:
    Dim strErrMsg As String
    Dim lngErrIconBtn As Long
    
    strErrMsg = "Error " & Err.Number & " (" & Err.Description & ") " _
        & "occurred in procedure VerifyUserID of " _
        & "VBA Document basSecurity_wrkgrp"
    lngErrIconBtn = vbOKOnly + vbInformation

    MsgBox strErrMsg, lngErrIconBtn, "Error"
    
    Resume exit_UserExists

End Function

Public Function ReadSecGrp(strUser As String) As String
'Purpose  : Get CurrentUser's User Group
'DateTime : 10/23/2003 15:19
'Author   : Bill Mosca
    Dim cat As New ADOX.Catalog
    Dim cnn As ADODB.Connection
    Dim grp As ADOX.Group


    On Error GoTo err_ReadSecGrp

    ' Open the catalog
    Set cnn = CurrentProject.Connection
    cat.ActiveConnection = cnn
    
    For Each grp In cat.Users(strUser).Groups
        If grp.Name = "Users" Then
            'Skip this group.
        Else
            ReadSecGrp = grp.Name
        End If
    Next


exit_ReadSecGrp:
    On Error Resume Next
    Set cat = Nothing
    Set cnn = Nothing
    Exit Function

err_ReadSecGrp:
    Dim strErrMsg As String
    Dim lngErrIconBtn As Long
    
    strErrMsg = "Error " & Err.Number & " (" & Err.Description & ") " _
        & "occurred in procedure VerifyUserID of " _
        & "VBA Document basSecurity_wrkgrp"
    lngErrIconBtn = vbOKOnly + vbInformation

    MsgBox strErrMsg, lngErrIconBtn, "Error"
    
    Resume exit_ReadSecGrp


End Function
    
Public Function GetMyPermissions(strDoc As String, strCntr As String) As String
'Purpose  : Get user permissions for an object. Allows code to stop error
'           and gracefully tell user if permissions are lacking for object.
'DateTime : 12/8/2003 12:10
'Author   : Bill Mosca
    Dim cntr As DAO.Container
    Dim db As DAO.Database
    Dim doc As DAO.Document
    Dim lngPerm As Long
    Dim strUGrp As String
    Dim strPermissions As String
    Const NO_ACCESS As Long = 0
    Const FULL_ACCESS As Long = 1048575
    Const DELETE_PERM As Long = 65536
    
    On Error GoTo err_GetMyPermissions

    strUGrp = ReadSecGrp(CurrentUser)
    
    Set db = CurrentDb
    Set cntr = db.Containers(strCntr)
    Set doc = cntr.Documents(strDoc)
    doc.UserName = strUGrp
    
    lngPerm = doc.Permissions
    Select Case lngPerm
        Case NO_ACCESS
            strPermissions = "None"
        Case FULL_ACCESS
            strPermissions = "Full"
        
        Case DELETE_PERM
            strPermissions = "Delete"
    End Select
    
    GetMyPermissions = strPermissions

exit_GetMyPermissions:
    On Error Resume Next
    Set doc = Nothing
    Set cntr = Nothing
    Set db = Nothing
    Exit Function

err_GetMyPermissions:
    Dim strErrMsg As String
    Dim lngErrIconBtn As Long
    
    strErrMsg = "Error " & Err.Number & " (" & Err.Description & ") " _
        & "occurred in procedure VerifyUserID of " _
        & "VBA Document basSecurity_wrkgrp"
    lngErrIconBtn = vbOKOnly + vbInformation

    MsgBox strErrMsg, lngErrIconBtn, "Error"
    
    Resume exit_GetMyPermissions

End Function

Public Sub ListUsers()
'Purpose  : Development use only.
'           List all users in wrkgroup.
'DateTime : 12/19/2003 15:10
'Author   : Bill Mosca
    Dim cnn As ADODB.Connection
    Dim cat As New ADOX.Catalog
    Dim usr As ADOX.User
    

    On Error GoTo err_ListUsers

    Set cnn = CurrentProject.Connection
    cat.ActiveConnection = cnn
    
    For Each usr In cat.Users
        Debug.Print usr.Name
    Next
        Debug.Print cat.Users.Count
        

exit_ListUsers:
    On Error Resume Next
    Set cat = Nothing
    Set cnn = Nothing
    Exit Sub

err_ListUsers:
    Dim strErrMsg As String
    Dim lngErrIconBtn As Long
    
    strErrMsg = "Error " & Err.Number & " (" & Err.Description & ") " _
        & "occurred in procedure VerifyUserID of " _
        & "VBA Document basSecurity_wrkgrp"
    lngErrIconBtn = vbOKOnly + vbInformation

    MsgBox strErrMsg, lngErrIconBtn, "Error"
    
    Resume exit_ListUsers


End Sub

Public Function GetUserInfo_Script(lngProperty) As String
'Purpose  : Get User and computer info using Scripting DLL.
'DateTime : 10/25/2004 06:56
'Author   : Bill Mosca
    Dim objNet As Object
  
    Set objNet = CreateObject("wscript.network")
    
    Select Case lngProperty
        Case ObjectProp.USER_NAME
            GetUserInfo_Script = objNet.UserName
        Case ObjectProp.DOMAIN_NAME
            GetUserInfo_Script = objNet.UserDomain
        Case ObjectProp.PC_NAME
            GetUserInfo_Script = objNet.ComputerName
    End Select
    
    Set objNet = Nothing

End Function

Public Function EnvironID()
'Purpose  : Use Environ to get User ID
'DateTime : 10/26/2004 07:50
'Author   : Bill Mosca
    Dim strUserID As String
    Dim strPCName As String
    Dim x As Long
        
    strUserID = Environ("USERNAME")
    strPCName = Environ("COMPUTERNAME")
    
    For x = 1 To 100
        Debug.Print Environ(x)
    Next x
    
    
End Function

Function IsADSMember(strDomain As String, strGroup _
   As String, strMember As String) As Boolean
'Purpose  : Test name for Active Directory Member
'DateTime : 7/26/2007 07:43
'Author   : Bill Mosca
'Reference:
  Dim grp As Object
  'If using Active DS Type Library as reference use:
  'Dim grp As ActiveDS.IADsGroup
  Dim strPath As String
  
  strPath = "WinNT://" & strDomain & "/"
  Set grp = GetObject(strPath & strGroup & ",group")
  IsADSMember = grp.IsMember(strPath & strMember)
  
End Function

Public Function ToggleDBWindow(bolHide As Boolean)
'Purpose  : Show/Hide DBWindow.
'           Selecting a table will show DB window if it is hidden.
'           If it is not hidden, window will simply get focus.
'DateTime : 10/11/2007 12:14
'Author   : Bill Mosca
'Reference: none
    
    'Set focus on DB window.
    DoCmd.SelectObject acTable, , True

    'Hide DB window.
    If bolHide = True Then
        DoCmd.RunCommand acCmdWindowHide
    End If

End Function