'*******************************************************************************
' Project   : Generic
' Module    : basSecurity
' DateTime  : 12/4/2007 08:10
' Author    : Bill Mosca
' Purpose   : Handles all Inserts, edits, deletes of wrkgrp file. Also, returns
'             various user information.
' Index     :(Updated on 3/04/2010)
  ' CleanUserKey - Replaces double quotes in encrypted string with SQL accepted """""".
  ' SetUserID - Set global UserID info. Done at startup,
  ' CurrentUserName - Returns the network login name
  ' FullUserName - Get Full User Name. Defaults to "FirstName LastName"
  ' PermissionsRank - Get current user's permissions rank.
  ' net_UserGroup - Get the User Group for current user.
  ' EnvironInfo - Get NT Environment Info for either User Domain
  ' GetUserInfo_Script - Get User and computer info using Scripting DLL.
  ' CheckNTUserPermission - Set global encrypted ID and check if user
  ' Rot47 - Creates encrypted UserKey for UserID.
  ' GenR8PWD - Generate random password.
  ' KeyCode - Produce a unique long key for a string
  ' RecUpdate - Set record change Modified Date and user for audit trail
  ' RecInsert - Fills UserCreated and DateCreated controls on calling form.
  ' OpenBE - Open Special FE to access tables in BE.
  ' ScriptShell - Use instead of Shell().
  ' ToggleDBWindow - Show/Hide DBWindow.
'*******************************************************************************

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

Private Declare Function GetUserNameEx Lib "secur32.dll" Alias "GetUserNameExA" _
    (ByVal NameFormat As EXTENDED_NAME_FORMAT, ByVal lpNameBuffer As String, _
    ByRef nSize As Long) As Long

Private Enum EXTENDED_NAME_FORMAT
    NameUnknown = 0
    NameFullyQualifiedDN = 1
    NameSamCompatible = 2
    NameDisplay = 3
    NameUniqueId = 6
    NameCanonical = 7
    NameUserPrincipal = 8
    NameCanonicalEx = 9
    NameServicePrincipal = 10
End Enum

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 gstrUserKey As String

'Used for SQL statements (dbl quotes fixed)
Public gstrCleanKey As String

Public Const gcDblQuote As String = """"""


Public Function CheckNTUserPermission() As Boolean
'Purpose  : Set global encrypted ID and check if user
'           is in tblUsers.
'           Uses global encrypted ID gstrUserKey
'DateTime : 2/8/2007 13:24
'Author   : Bill Mosca
'Reference: none
    Dim strMSG As String
    Dim strTitle As String
    Dim strUserKey As String
    
    If gstrCleanKey = "" Then SetUserID

    If DCount("*", "tblUsers", _
              "UserKey=" & Chr(34) & gstrCleanKey & Chr(34)) = 0 Then
        strTitle = GetSummaryInfo("Title", False)
        strMSG = "You are not authorized to view this application. " _
                 & "Please contact your administrator to set permisions for you."
        MsgBox strMSG, vbCritical, strTitle
        Quit
    End If

End Function


Public Function CleanUserKey(strIn As String) As String
'Purpose  : Replaces double quotes in encrypted string with SQL accepted """""".
'           Used when encrypted string has dbl quotes within it.
'DateTime : 6/22/2007 09:17
'Author   : Bill Mosca
'Reference:
    Dim strOut As String
    strOut = Replace(strIn, Chr(34), gcDblQuote)
    CleanUserKey = strOut
    
End Function


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
    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
    
End Function


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

Public Function FullUserName(Optional lngFormat As Long = 3) As String
'Purpose  : Get Full User Name. Defaults to "FirstName LastName"
'DateTime : 11/6/2012 06:46
'Author   : KPD-Team 2001
'           URL: http://www.allapi.net/
'           E-Mail: KPDTeam@allapi.net
    Dim sBuffer As String, Ret As Long
    Dim sUserName As String
    
    sBuffer = String(255, 0)
    Ret = Len(sBuffer)
    GetUserNameEx lngFormat, sBuffer, Ret
    FullUserName = Left$(sBuffer, InStr(sBuffer, Chr$(0)) - 1)

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


Sub GetEnvironVariables()
'Purpose  : Loops through Environ function to get all
'           variables.
'DateTime : 9/20/2013 11:15
'Author   : Rob Cooper
'Requires :
    Dim i As Integer
    Dim stEnviron As String
    For i = 1 To 50
        ' get the environment variable
        stEnviron = Environ(i)
        ' see if there is a variable set
        If Len(stEnviron) > 0 Then
            Debug.Print i, Environ(i)
        Else
            Exit For
        End If
    Next
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 KeyCode(Password As String) As Long
'Purpose  : Produce a unique long key for a string
'DateTime : 3/04/2010 15:09
'Author   : Microsoft
'Requires :
    Dim I As Integer
    Dim Hold As Long

    For I = 1 To Len(Password)
        Select Case (Asc(Left(Password, 1)) * I) Mod 4
            Case Is = 0
                Hold = Hold + (Asc(Mid(Password, I, 1)) * I)
            Case Is = 1
                Hold = Hold - (Asc(Mid(Password, I, 1)) * I)
            Case Is = 2
                Hold = Hold + (Asc(Mid(Password, I, 1)) * _
                        (I - Asc(Mid(Password, I, 1))))
            Case Is = 3
                Hold = Hold - (Asc(Mid(Password, I, 1)) * _
                        (I + Len(Password)))
        End Select
    Next I

    KeyCode = Hold

End Function



Function LDAPAuthenticate(ByVal strUserName As String, _
        ByVal strpassword As String, ByVal strDomain As String) As Boolean
'Purpose  : Checks username and password using AD Authentication.
'DateTime : 8/28/2012 09:16
'Author   : Unknown
'Requires :
    Dim LDAPPath As String
    Dim conn As ADODB.Connection
    Dim cmd As ADODB.Command
    Dim rs As ADODB.Recordset
    Const ADS_SCOPE_SUBTREE As Long = 2

    On Error GoTo err_PROC

    LDAPPath = "LDAP://" & strDomain & "/" _
            & "DC=" & Left(strDomain, InStr(1, strDomain, ".") - 1) _
            & ",DC=" & Mid(strDomain, InStr(1, strDomain, ".") + 1)
    'LDAPPath = "LDAP://MyDomain.org/DC=MyDomain,DC=org"

    Set conn = New ADODB.Connection
    Set cmd = New ADODB.Command
    conn.Provider = "ADsDSOObject"

    conn.Properties("User ID") = strDomain & "\" & strUserName
    conn.Properties("Password") = "" & strpassword
    conn.Properties("Encrypt Password") = True
    conn.Properties("ADSI Flag") = 3

    conn.Open "Active Directory Provider"

    Set cmd.ActiveConnection = conn

    cmd.Properties("Page Size") = 1000
    cmd.Properties("Searchscope") = ADS_SCOPE_SUBTREE

    cmd.CommandText = "SELECT Name " _
            & "FROM '" & LDAPPath & "' " _
            & "WHERE objectCategory='" & strUserName & "'"

    Set rs = cmd.Execute
    LDAPAuthenticate = True


exit_PROC:
    On Error Resume Next
    Set cmd = Nothing
    Set rs = Nothing
    Set conn = Nothing
    Exit Function

err_PROC:
    Dim strErrMsg As String
    Dim lngIcon As Long

    Select Case Err.Number
        Case -2147217911
            strErrMsg = "Incorrect User name or Password!"

        Case Else
            strErrMsg = "Error " & Err.Number & " (" & Err.Description & ") " _
                    & "occurred in procedure LDAPAuthenticate of " _
                    & "VBA Document Module2"
    End Select

    lngIcon = vbOKOnly + vbInformation
    MsgBox strErrMsg, lngIcon, "Error"
    Resume exit_PROC

End Function

Public Function net_UserGroup() As String
'Purpose  : Get the User Group for current user.
'DateTime : 5/22/2009 10:20
'Author   : Bill Mosca
'Requires :
    Dim strKeyCode As String
    Dim strUsrGrpID As String


    If gbolErrorTrapOff = False Then On Error GoTo err_net_UserGroup

    If gstrCleanKey = "" Then SetUserID
    
    strUsrGrpID = _
        Nz(DLookup("UGrpID", "tblUsers", _
        "UserKey=" & Chr(34) & gstrCleanKey & Chr(34)), "")
    net_UserGroup = UCase(strUsrGrpID)


exit_net_UserGroup:
    On Error Resume Next
    Exit Function

err_net_UserGroup:
    Dim strErrMsg As String
    Dim lngIconBtn As Long
    Dim bolQuit As Boolean
    
    Select Case Err.Number
        Case 3734
            'DBA has locked backend.
            strErrMsg = "Database has been locked for maintenance." _
                & vbNewLine & vbNewLine _
                & "This application will now close."
            lngIconBtn = vbOKOnly + vbInformation
            bolQuit = True
        Case Else
            gProcName = "net_UserGroup"
            glngErrNum = Err.Number
            gstrErrDescr = Err.Description
            glngLineNum = Erl
            Call ErrorLog("basSecurity")
    End Select

    If strErrMsg <> "" Then MsgBox strErrMsg, lngIconBtn, _
        GetSummaryInfo("Title", False)
    If bolQuit = True Then Quit
    Resume exit_net_UserGroup

    
End Function


Public Sub OpenBE()
'Purpose  : Open Special FE to access tables in BE.
'DateTime : 10/11/2007 10:58
'Author   : Bill Mosca
    ScriptShell gconBEFolder & gconTableAccess
    
End Sub


Public Function PermissionsRank(strUserGrp As String) As Integer
'Purpose  : Get current user's permissions rank.
'DateTime : 5/22/2009 10:20
'Author   : Bill Mosca
'Requires :
    Dim intRank As Integer
    
    intRank = DLookup("PermissionsRank", _
        "tblUserGroups", _
        "UGrpID='" & strUserGrp & "'")
    PermissionsRank = intRank
    
End Function


Public Sub RecInsert(frm As Object)
'Purpose  : Fills UserCreated and DateCreated controls on calling form.
'DateTime : 5/22/2009 10:21
'Author   : Bill Mosca
'Requires :
    If gstrUserKey = "" Then SetUserID
    frm.UserCreated = Rot47(gstrUserKey)
    frm.DateCreated = Now()

End Sub


Public Sub RecUpdate(frm As Object)
'Purpose  : Set record change Modified Date and user for audit trail
'DateTime : 6/22/2007 14:30
'Author   : Bill Mosca

    If gbolErrorTrapOff = False Then On Error GoTo err_RecUpdate

    If gstrUserKey = "" Then SetUserID
    frm.UserModified = Rot47(gstrUserKey)
    frm.DateModified = Now()

exit_RecUpdate:
    On Error Resume Next
    Exit Sub

err_RecUpdate:
    Dim strErrMsg As String
    Dim lngIconBtn As Long
    
    Select Case Err.Number
        Case Else
            gProcName = "RecUpdate"
            glngErrNum = Err.Number
            gstrErrDescr = Err.Description
            glngLineNum = Erl
            Call ErrorLog("basSecurity")
    End Select

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

End Sub


Public Function Rot47(ByVal sData As Variant) As String
'Purpose  : Creates encrypted UserKey for UserID.
'DateTime : 5/25/2007 10:20
'Reference:
    Const cLower As Long = 33   'ascii for !
    Const cUpper As Long = 126  'ascii for ~
    Const cShift = 47
    Dim sReturn As String
    Dim bData() As Byte
    Dim iCount As Integer
    Dim iCode As Integer

    On Error GoTo ProcErr
    
    If VarType(sData) <> vbString Then sData = sData & ""
    ReDim bData(Len(sData)) As Byte
    bData = StrConv(sData, vbFromUnicode)
    For iCount = 0 To UBound(bData)
        iCode = bData(iCount)
        If ((iCode >= cLower) And (iCode <= cUpper)) Then
            iCode = iCode + cShift
            If iCode > cUpper Then iCode = iCode - cUpper + cLower - 1
            bData(iCount) = iCode
        End If
    Next iCount
    sReturn = StrConv(bData, vbUnicode)

ProcEnd:
    Rot47 = sReturn
    Exit Function

ProcErr:
    sReturn = ""
    Resume ProcEnd

End Function


Public Function ScriptShell(strFile As String)
'Purpose  : Use instead of Shell().
'           Works for shortcuts, too.
'DateTime : 9/28/2007 11:28
'Author   : Bill Mosca
'Reference: http://msdn2.microsoft.com/en-us/library/d5fk67ky.aspx
'WScript.Shell object's arguments:
'    object.Run(strCommand, [intWindowStyle], [bWaitOnReturn])
'
' [intWindowStyle]:
'    0 Hides the window and activates another window.
'    1 Activates and displays a window. If the window is minimized
'        or maximized, the system restores it to its original size
'        and position. An application should specify this flag when
'        displaying the window for the first time.
'    2 Activates the window and displays it as a minimized window.
'    3 Activates the window and displays it as a maximized window.
'    4 Displays a window in its most recent size and position.
'        The active window remains active.
' [bWaitOnReturn]: boolean
    Dim WshShell As Object

    'VBScript
    'Set WshShell = WScript.CreateObject("WScript.Shell")

    Set WshShell = CreateObject("WScript.Shell")
    
    'Shortcut example
    'WshShell.Run "C:\FRS3000\StartFRS3000.lnk"
    
    WshShell.Run strFile

    Set WshShell = Nothing

End Function


Public Sub SetUserID()
'Purpose  : Set global UserID info. Done at startup,
'           but may also be used if string value is accidentally lost.
'DateTime : 6/22/2007 10:16
'Author   : Bill Mosca
    Dim strTitle As String
    Dim strMSG As String
    
    gstrUserKey = Rot47(EnvironInfo)
    gstrCleanKey = CleanUserKey(gstrUserKey)
    'Check if user is in table. Quit if not found.
    If DCount("*", "tblUsers", _
      "UserKey=" & Chr(34) & gstrCleanKey & Chr(34)) = 0 Then
        strTitle = gstrProjTitle
        strMSG = "You are not authorized to view this application. " _
        & "Please contact your administrator to set permisions for you."
        MsgBox strMSG, vbCritical, strTitle
        Quit
    End If
    
    gstrUserGrp = net_UserGroup
    

End Sub


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
    DoCmd.SelectObject acTable, , True

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

End Function