'*******************************************************************************
' Project   : Generic
'
' Module    : basSecurity_NT
' DateTime  : 6/04/2010 14:45
' Author    : Bill Mosca
' Purpose   : Uses NT user name as Identification. tblP
' References:
' Index     :(Updated on 6/22/2010)
  ' CurrentUserName - Returns the network login name
  ' ReadSecGrp - Gets User Group for user.
  ' GetUserInfo_Script - Get User and computer info using Scripting DLL.
'*******************************************************************************

Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" _
    (ByVal lpBuffer As String, nSize As Long) As Long

Public Enum ObjectProp
    USER_NAME
    PC_NAME
    DOMAIN_NAME
End Enum

'UserID info. Set when startup form loads.
'Used with non-ULS security
Public gstrUserGrp As String
Public gstrUserName As String

'Authorized AD Group
Public Const gconADGroup As String _
        = "ADGroupNameGoesHere"
Public Const gconDBA As String _
        = "SQLDBA"

Public Function CurrentUserName() As String
'Purpose  : Returns the network login name
'DateTime : 5/28/2002 09:54
'Author   : Bill Mosca
    Dim lngLen As Long
    Dim x As Long
    Dim strUserName As String
    
    'Create buffer

    If gbolErrorTrapOff = False Then On Error GoTo err_PROC

    strUserName = String(254, Chr$(0))
    lngLen = Len(strUserName)
    x = GetUserName(strUserName, lngLen)
    
    If (x > 0) Then
        'Trucate remaining buffer space from end of string.
        CurrentUserName = Left$(strUserName, InStr(strUserName, Chr$(0)) - 1)
    Else
        CurrentUserName = vbNullString
    End If

exit_PROC:
    Exit Function

err_PROC:
    Dim strErrMsg As String
    Dim lngIconBtn As Long
    
    Select Case Err.Number
        Case 2501
            'Open cancelled.
            strErrMsg = "No information for selected filter."
            lngIconBtn = vbOKOnly + vbInformation
        Case Else
            gProcName = "CurrentUserName"
            glngErrNum = Err.Number
            gstrErrDescr = Err.Description
            glngLineNum = Erl
            Call ErrorLog("basSecurity_NT")
    End Select

    If strErrMsg <> "" Then MsgBox strErrMsg, lngIconBtn, _
        GetSummaryInfo("Title")
    
    Resume exit_PROC
    
End Function

Public Function DeleteUser(strUserID As String) As Boolean
    Dim cnn As ADODB.Connection
    Dim lngRecs As Long
    Dim strSQL As String
    
    Set cnn = CurrentProject.Connection
    'Delete from tblUsers.
    strSQL = "DELETE  FROM tblUsers " _
        & "WHERE UserID=" & Chr(34) & strUserID & Chr(34)
    cnn.Execute strSQL, lngRecs
    
    DeleteUser = (lngRecs > 0)
    Set cnn = Nothing

End Function



Public Sub GetADGroupUsers(strDomain As String, strGroup As String)
'Purpose  : Gets all AD user names and puts them into a table
'DateTime : 7/28/2010 14:34
'Author   : Bill Mosca
'Requires : DAO
    Dim objGroup As Object
    Dim objRootDSE As Object
    Dim objNet As Object
    Dim objUser As Object
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim strSQL As String
    Dim i As Integer
    
    
    Set db = CurrentDb
    strSQL = "SELECT * FROM ADUsers WHERE 1 = 2"
    Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)


    Set objNet = CreateObject("WScript.Network")
    Set objRootDSE = GetObject("LDAP://rootDSE")
    Set objGroup = GetObject("WinNT://" & strDomain & "/" & strGroup & ",group")
    For Each objUser In objGroup.Members
        i = i + 1
        With rs
            .AddNew
            !ADGroup = strGroup
            !UserName = objUser.Name
            .Update
        End With
    Next
    Set rs = Nothing
    Set db = Nothing
    Set objGroup = Nothing
    Set objRootDSE = Nothing
    Set objNet = Nothing
    
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



Function PasswordComplies(strIn As String) As Boolean
'Purpose  : Test string 8-20 chars in length
'           and at least 1 of each
'           Upper case; lower case; digit
'DateTime : 6/08/2012 14:57
'Author   : Bill Mosca
'Requires : If using late binding use Reference 
'           Microsoft VBScripting Regular Expressions 5.5
    Dim re As New RegExp
    Dim i As Variant
    
    re.Pattern = "^(?=.*\d)(?=.*[a-z])(?=.*[A-Z]).8,20$"
    re.Global = True
    PasswordComplies = re.test(strIn)
    
End Function

Public Function ReadSecGrp(strUserID) As String
'Purpose  : Gets User Group for user.
'DateTime : 6/07/2010 11:17
'Author   : Bill Mosca
'Requires :

    If gbolErrorTrapOff = False Then On Error GoTo err_PROC

    ReadSecGrp = DLookup("U_GroupID", "tblUsers", "UserID = '" & strUserID & "'")

exit_PROC:
    Exit Function

err_PROC:
    Dim strErrMsg As String
    Dim lngIconBtn As Long
    
    Select Case Err.Number
        Case 2501
            'Open cancelled.
            strErrMsg = "No information for selected filter."
            lngIconBtn = vbOKOnly + vbInformation
        Case Else
            gProcName = "GetUserGroup"
            glngErrNum = Err.Number
            gstrErrDescr = Err.Description
            glngLineNum = Erl
            Call ErrorLog("basSecurity_NT")
    End Select

    If strErrMsg <> "" Then MsgBox strErrMsg, lngIconBtn, _
        GetSummaryInfo("Title", False)
    
    Resume exit_PROC
End Function