User List (1 Viewer)

[galvinjaf]

Good Evening,

I found a code from another website, that will show you the Computer/UserName/Connect information of all users within the database. I'm not much of a programmer, and was wondering what type of code I need to put where to get this particular code to be able to capture which user logged on by udsername...?

When someone logs onto my database, they enter a username and password which is stored using tempvars (something like that). Below is the code for my log on form, and below that is the code to this user list. Any ideas on what I edit?

Private Function GenerateUserList()
'The User List Schema information requires this magic number. For anyone
'who may be interested, this number is called a GUID or Globally Unique
'Identifier - sorry for digressing
Const conUsers = "{947bb102-5d43-11d1-bdbf-00c04fb92675}"
  
Dim cnn As ADODB.Connection, fld As ADODB.Field, strUser As String
Dim rst As ADODB.Recordset, intUser As Integer, varValue As Variant
  
Set cnn = CurrentProject.Connection
Set rst = cnn.OpenSchema(Schema:=adSchemaProviderSpecific, SchemaID:=conUsers)
  
'Set List Box Heading
strUser = "Computer;UserName;Connected?;Suspect?"
  
With rst    'fills Recordset (rst) with User List data
  Do Until .EOF
    intUser = intUser + 1
      For Each fld In .Fields
        varValue = fld.Value
          'Some of the return values are Null-Terminated Strings, if
          'so strip them off
          If InStr(varValue, vbNullChar) > 0 Then
            varValue = Left(varValue, InStr(varValue, vbNullChar) - 1)
          End If
          strUser = strUser & ";" & varValue
      Next
         .MoveNext
  Loop
End With
  
Me!txtTotalNumOfUsers = intUser        'Total # of Users
  
'Set up List Box Parameters
Me!lstUsers.ColumnCount = 4
Me!lstUsers.RowSourceType = "Value List"
Me!lstUsers.ColumnHeads = False
  lstUsers.RowSource = strUser       'populate the List Box
  
'Routine cleanup chores
Set fld = Nothing
Set rst = Nothing
Set cnn = Nothing

End Function

Private Sub Command1_Click()
Dim userLevel As Integer

    If IsNull(Me.txtLoginID) Then
        MsgBox "Please enter LoginID", vbInformation, "LoginID Required"
        Me.txtLoginID.SetFocus
    ElseIf IsNull(Me.txtPassword) Then
        MsgBox "Please enter password", vbInformation, "Password Required"
        Me.txtPassword.SetFocus
    Else
        'process the job
        If (IsNull(DLookup("User_Login", "tblUser", "User_login ='" & Me.txtLoginID.Value & "'"))) Or _
           (IsNull(DLookup("Password", "tblUser", "Password ='" & Me.txtPassword.Value & "'"))) Then
            MsgBox "Incorrect LoginID or Password"
        Else
           userLevel = DLookup("UserSecurity", "tblUser", "User_Login = '" & Me.txtLoginID.Value & "'")
                   If userLevel = 1 Then
           MsgBox "LoginID and Password Correct"
           TempVars.Add "sUsername", Me.txtLoginID.Value
                    DoCmd.Close
                    DoCmd.Close acForm, "Login", acSaveYes
                    DoCmd.OpenForm "frmWhatisnew"
                Else
           MsgBox "LoginID and Password Correct"
           TempVars.Add "sUsername", Me.txtLoginID.Value
                    DoCmd.Close
                    DoCmd.Close acForm, "Order Review", acSaveYes
                    DoCmd.OpenForm "frmNavigation_controlled_User"
                    End If
                                     
                        
                    
        End If
    End If
End Sub

 

[Guus2005]

There is no need to create a list of users. So you don't have to use the first function.
It is good practise to store the encrypted password instead of the actual password. Below is an example "Encrypt" which encrypts the password and adds a salt. The resulting string can be stored in your database.
The form code below encrypts the password and checks it against the value found in the database.

Your frmLogin code :

Option Compare Database
Option Explicit

Private Sub Form_Load()
'Default login id is windows username
    Me.txtLoginId = GetCurrentUserName
End Sub

Private Sub Command1_Click()
    
    Dim rst          As Recordset
    Dim dbs          As Database
    Dim strSql       As String
    Dim intUserLevel As Integer
    
    Const clngSalt = 1234567890
    
    Set dbs = CurrentDb

    If Len(Nz(Me.txtLoginId, "")) = 0 Then ' Not only check for value null, also check for empty string
        MsgBox "Please enter LoginID", vbInformation, "LoginID Required"
        Me.txtLoginId.SetFocus
        Exit Sub
    End If
    
    If Len(Nz(Me.txtPassword, "")) Then
        MsgBox "Please enter password", vbInformation, "Password Required"
        Me.txtPassword.SetFocus
        Exit Sub
    End If
    
    'process the job
    strSql = "Select UserLevel from tblUser Where Login = '" & Me.txtLoginId & "' and Password = '" & Encrypt(Me.txtPassword, clngSalt) & "'"
    
    Set rst = dbs.OpenRecordset(strSql)
    
    If rst.EOF Then
        MsgBox "Login and password combination not found", vbInformation, "Try again"
        Me.txtLoginId.SetFocus
        Exit Sub
    Else
        intUserLevel = rst.Fields(0)
    End If
    
    TempVars.Add UserLevel, intUserLevel ' Set userlevel.
    
    If intUserLevel = 1 Then
        DoCmd.Close acForm, Me.Name
        DoCmd.OpenForm "frmWhatisnew"
    Else ' userlevel <> 1
        DoCmd.Close acForm, Me.Name
        DoCmd.OpenForm "frmNavigation_controlled_User"
    End If

End Sub

Put this code in a module.

Option Compare Database
Option Explicit

' 32bit
'Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
' 64bit
Private Declare PtrSafe Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Public Function GetCurrentUserName() As String
' Get windows user name
    Dim lng As Long
    Dim sUser As String
    
    sUser = Space$(255)
    lng = GetUserName(sUser, 255)
    
    If lng <> 0 Then
       GetCurrentUserName = Left$(sUser, InStr(sUser, Chr(0)) - 1)
    Else
       Err.Raise Err.LastDllError, , "A system call returned an error code of " & Err.LastDllError
    End If
    
End Function

Public Function Encrypt(strIn As String, lngSalt As Long) As String
' Usage: Encrypt("P455W0rd", 12345)
' Result: 1239312301123001230012398122971236312381
' Store the result in the table.

    Dim strChr As String
    Dim i      As Integer
    
    For i = 1 To Len(strIn)
        strChr = strChr & CStr(Asc(Mid(strIn, i, 1)) Xor lngSalt)
    Next i
    
    Encrypt = strChr
    
End Function

depending on your installed office version 32 or 64 bit, please uncheck the appropriate api.

HTH

Share & enjoy!

 

[galvinjaf]

Sorry for the late reply, thank you! I've taken your advice!