Advance Login System Excel VBA Software Pradip VedantSri
Yah This Workbook Code hai
' yah ThisWorkbook ka code hai
Private Sub Workbook_Open()
' Hide specific sheets (Sheet2, Sheet3)
ThisWorkbook.Sheets("Sheet2").Visible = xlSheetVeryHidden
ThisWorkbook.Sheets("Sheet3").Visible = xlSheetVeryHidden
' Hide the main workbook window and show UserForm1
Application.Visible = False
UserForm1.Show
End Sub
'jaise hi koi excel ko close kre, data auto save aur close ka code
Private Sub Workbook_BeforeClose(Cancel As Boolean)
' Update logout details before closing
Call UpdateLogoutDetails
' Save workbook changes
ThisWorkbook.Save
End Sub
' jaise hi koi userform direct close kre auto data save and close ka code
Private Sub Workbook_Deactivate()
' Update logout details when workbook loses focus
Call UpdateLogoutDetails
End Sub
' Users ke logout details ko Sheet3 logs me update ka code hai
Private Sub UpdateLogoutDetails()
Dim logSheet As Worksheet
Dim lastRow As Long
Dim currentUser As String
Dim logoutRow As Long
Dim loginDateTime As Date
Dim logoutDateTime As Date
Dim durationMinutes As Double
' Reference the log sheet (Sheet3)
Set logSheet = ThisWorkbook.Sheets("Sheet3")
' Get the current logged-in user from UserForm1
On Error Resume Next
currentUser = UserForm1.txtUsername.Value
On Error GoTo 0
' If no user is logged in, exit the subroutine
If currentUser = "" Then Exit Sub
' Find the last used row in Sheet3
lastRow = logSheet.Cells(logSheet.Rows.Count, 1).End(xlUp).Row
' Search for the current user's last login row with "In Progress" status
For logoutRow = lastRow To 2 Step -1
If logSheet.Cells(logoutRow, 1).Value = currentUser Then ' Match username
If logSheet.Cells(logoutRow, 5).Value = "In Progress" Then ' Check "In Progress" status
' Calculate duration
loginDateTime = logSheet.Cells(logoutRow, 2).Value + logSheet.Cells(logoutRow, 3).Value ' Login Date + Time
logoutDateTime = Now ' Current date and time for logout
durationMinutes = DateDiff("n", loginDateTime, logoutDateTime) ' Duration in minutes
' Update the log sheet with duration, logout date, and logout time
logSheet.Cells(logoutRow, 5).Value = durationMinutes & " minutes" ' Column E: Duration
logSheet.Cells(logoutRow, 6).Value = Date ' Column F: Logout Date
logSheet.Cells(logoutRow, 7).Value = Time ' Column G: Logout Time
Exit For ' Exit the loop after updating
End If
End If
Next logoutRow
End Sub
' Users ke according sheet1 me data separatly entry ka code hai
Public Sub LogUserLogin(username As String, role As String)
Dim logSheet As Worksheet
Dim lastRow As Long
' Set the log sheet (Sheet3)
Set logSheet = ThisWorkbook.Sheets("Sheet3")
' Find the next empty row in the sheet
lastRow = logSheet.Cells(logSheet.Rows.Count, 1).End(xlUp).Row + 1
' Add login details to the log sheet
With logSheet
.Cells(lastRow, 1).Value = username ' Username
.Cells(lastRow, 2).Value = Date ' Login Date
.Cells(lastRow, 3).Value = Time ' Login Time
.Cells(lastRow, 4).Value = role ' Role
.Cells(lastRow, 5).Value = "In Progress" ' Status
End With
End Sub
Yah Userform1 as Login Software ka code hai
'Yah Login Software ka code hai
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = 0 Then
MsgBox "Thanks for Using Excel Multi-Login Software.", vbExclamation, "Warning"
ThisWorkbook.Save
Unload Me
Application.Quit
End If
End Sub
'jaise koi Username type kre Uska Profile pic Load ho jaye
Private Sub txtUsername_AfterUpdate()
Dim ws As Worksheet
Dim lastRow As Long
Dim i As Long
Dim username As String
Dim found As Boolean
' Initialize
Set ws = ThisWorkbook.Sheets("Sheet2")
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
username = Trim(txtUsername.Value)
found = False
If username = "" Then
lblMessage.Caption = "Please enter a username."
lblMessage.ForeColor = vbRed
imgUser.Picture = LoadPicture() ' Clear image
Exit Sub
End If
' Search for the username in Sheet2
For i = 2 To lastRow
If ws.Cells(i, 1).Value = username Then
found = True
' Load user photo from Column J
If ws.Cells(i, 10).Value <> "" Then
On Error Resume Next
imgUser.Picture = LoadPicture(ws.Cells(i, 10).Value)
On Error GoTo 0
Else
imgUser.Picture = LoadPicture() ' Clear image if no photo found
End If
Exit For
End If
Next i
If Not found Then
lblMessage.Caption = "Username not found."
lblMessage.ForeColor = vbRed
imgUser.Picture = LoadPicture() ' Clear image
Else
lblMessage.Caption = "Username found! Please enter your password."
lblMessage.ForeColor = vbBlack
End If
End Sub
'Login Button ka code
Private Sub cmdLogin_Click()
Dim wsLogin As Worksheet, wsData As Worksheet, logSheet As Worksheet
Dim username As String, password As String, role As String
Dim lastRow As Long, i As Long, found As Boolean
On Error GoTo ErrorHandler ' Error handling
' Get username and password from textbox (assuming they exist)
username = Trim(txtUsername.Value)
password = Trim(txtPassword.Value)
' Set references to worksheets (assuming sheet names are correct)
Set wsLogin = ThisWorkbook.Sheets("Sheet2")
Set wsData = ThisWorkbook.Sheets("Sheet1")
Set logSheet = ThisWorkbook.Sheets("Sheet3")
' Validate username and password (ensure they are not empty)
If username = "" Or password = "" Then
lblMessage.Caption = "Please enter both Username and Password."
lblMessage.ForeColor = vbRed
Exit Sub
End If
' Find user credentials in login sheet
lastRow = wsLogin.Cells(wsLogin.Rows.Count, 1).End(xlUp).Row
For i = 2 To lastRow
If wsLogin.Cells(i, 1).Value = username And wsLogin.Cells(i, 2).Value = password Then
found = True
role = wsLogin.Cells(i, 3).Value
Exit For ' Exit loop if credentials found
End If
Next i
' Handle login success or failure
If found Then
' Login successful
lblMessage.Caption = "Login Successful!"
lblMessage.ForeColor = vbBlack
' Set visibility and filter based on role
If role = "Admin" Then
MsgBox "Welcome Admin! You have full access.", vbInformation
For Each ws In ThisWorkbook.Sheets
ws.Visible = xlSheetVisible ' Show all sheets for Admin
Next ws
' Remove any existing filter on data sheet
With wsData
If .AutoFilterMode Then .AutoFilterMode = False
End With
Else
MsgBox "Welcome User! You have limited access.", vbInformation
For Each ws In ThisWorkbook.Sheets
If ws.Name = "Sheet3" Or ws.Name = "Sheet2" Or ws.Name = "Sheet3" Then
ws.Visible = xlSheetVeryHidden ' Hide specific sheets for user role
Else
ws.Visible = xlSheetVisible ' Show other sheets
End If
Next ws
' Apply filter on data sheet for User (assuming username in column H)
With wsData
If .AutoFilterMode Then .AutoFilterMode = False ' Remove any existing filter
.Columns("H").AutoFilter Field:=1, Criteria1:=username
End With
End If
' ... (rest of your login success code)
Me.Tag = CStr(lastRow) ' Assuming you need lastRow for some purpose
' Call UserForm2's filter function (if applicable)
If role <> "Admin" Then
UserForm2.FilterData username
End If
'----------------------------------------------------
' Log login details in Sheet5
With logSheet
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
.Cells(lastRow, 1).Value = username
.Cells(lastRow, 2).Value = Date
.Cells(lastRow, 3).Value = Time
.Cells(lastRow, 4).Value = role
.Cells(lastRow, 5).Value = "In Progress"
End With
'------------------------------------------------------
Me.Hide
UserForm2.Show vbModeless
Else
' Login failed
lblMessage.Caption = "Invalid Username or Password."
lblMessage.ForeColor = vbRed
End If
Exit Sub ' Normal Exit
ErrorHandler:
MsgBox "An error occurred: " & Err.Description & " Source: " & Err.Source, vbCritical, "Error"
End Sub
'Show Password ka code
Private Sub chkShowPassword_Click()
If chkShowPassword.Value = True Then
txtPassword.PasswordChar = ""
Else
txtPassword.PasswordChar = "*"
End If
End Sub
'Reset Button ka code
Private Sub cmdForget_Click()
Me.Hide
UserForm3.Show vbModeless
End Sub
'End of Login Software Code
Yah Userform2 as Data Entry ka code hai
'Yah DataEntry Userform2 ka code hai
Private Sub UserForm_Initialize()
Dim ws As Worksheet
Dim lastRow As Long
Dim nextSrNo As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
' Find last row before filtering
With ws
If .AutoFilterMode Then .AutoFilterMode = False
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
End With '?? End With ???? ??? ??
If lastRow >= 2 Then ' If data exists
nextSrNo = lastRow + 1 ' Start from the next row number
Else
nextSrNo = 1 ' Start from 1 if no data
End If
Me.txtSrNo.Value = nextSrNo
End Sub
'Yah Entry Button ka Code hai
Private Sub cmdEntry_Click()
Dim ws As Worksheet
Dim lastRow As Long
Dim currentUser As String
Dim entrySrNo As Long ' Use Long to store the entry Sr. No.
Set ws = ThisWorkbook.Sheets("Sheet1")
currentUser = UserForm1.txtUsername.Value
If txtItem.Value = "" Or txtQty.Value = "" Or txtRate.Value = "" Then
MsgBox "Please fill all fields before entry.", vbExclamation, "Error"
Exit Sub
End If
' Use the Sr. No. from the textbox
If IsNumeric(Me.txtSrNo.Value) Then
entrySrNo = CLng(Me.txtSrNo.Value)
Else
MsgBox "Invalid Sr. No. Please ensure it is a number.", vbExclamation, "Error"
Exit Sub
End If
With ws
If .AutoFilterMode Then .AutoFilterMode = False ' Remove filter before writing
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
End With
Application.EnableEvents = False
With ws
.Cells(lastRow, 1).Value = entrySrNo ' Store the Sr. No. from the textbox
.Cells(lastRow, 2).Value = txtItem.Value
.Cells(lastRow, 3).Value = txtQty.Value
.Cells(lastRow, 4).Value = txtRate.Value
.Cells(lastRow, 5).Value = txtQty.Value * txtRate.Value
.Cells(lastRow, 6).Value = Date
.Cells(lastRow, 7).Value = Time
.Cells(lastRow, 8).Value = currentUser
End With
Application.EnableEvents = True
MsgBox "Entry successful! Sr. No: " & entrySrNo, vbInformation, "Success"
Call ResetForm
If UserForm1.txtUsername.Value <> "Admin" Then
Call FilterData(currentUser)
End If
End Sub
' Yah users ke according data Entry ka code hai
Public Sub FilterData(ByVal username As String) 'Make it Public to access from other module
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
If .AutoFilterMode Then .AutoFilterMode = False ' Remove any existing filters
.Range("A1").AutoFilter Field:=8, Criteria1:=username
End With
End Sub
' Search for an entry by Sr. No.
Private Sub cmdSearch_Click()
Dim ws As Worksheet
Dim searchSrNo As Long
Dim lastRow As Long
Dim rowIndex As Long
Dim found As Boolean
Dim loggedInUser As String
' Reference Sheet1
Set ws = ThisWorkbook.Sheets("Sheet1")
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
' Validate input
If IsNumeric(txtUpdate.Value) Then
searchSrNo = CLng(txtUpdate.Value)
Else
MsgBox "Please enter a valid numeric Serial Number.", vbExclamation, "Invalid Input"
Exit Sub
End If
loggedInUser = UserForm1.txtUsername.Value
found = False
' Search for Sr. No.
For rowIndex = 2 To lastRow
If ws.Cells(rowIndex, 1).Value = searchSrNo Then
If ws.Cells(rowIndex, 8).Value = loggedInUser Or loggedInUser = "Admin" Then
txtSrNo.Value = ws.Cells(rowIndex, 1).Value
txtItem.Value = ws.Cells(rowIndex, 2).Value
txtQty.Value = ws.Cells(rowIndex, 3).Value
txtRate.Value = ws.Cells(rowIndex, 4).Value
txtTotal.Value = ws.Cells(rowIndex, 5).Value
found = True
Exit For
End If
End If
Next rowIndex
If found Then
MsgBox "Record loaded successfully.", vbInformation, "Search Complete"
Else
MsgBox "Record not found or access denied.", vbExclamation, "Not Found"
End If
End Sub
' Update an existing entry
Private Sub cmdUpdate_Click()
Dim ws As Worksheet
Dim lastRow As Long
Dim searchSrNo As Long
Dim i As Long
Dim username As String
Dim isFound As Boolean
' Reference Sheet1
Set ws = ThisWorkbook.Sheets("Sheet1")
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
' Validate input
If Not IsNumeric(txtSrNo.Value) Then
MsgBox "Please search for a valid numeric Serial Number before updating.", vbExclamation, "Error"
Exit Sub
End If
searchSrNo = CLng(txtSrNo.Value)
username = UserForm1.txtUsername.Value
isFound = False
' Search and update
For i = 2 To lastRow
If ws.Cells(i, 1).Value = searchSrNo And _
(ws.Cells(i, 8).Value = username Or username = "Admin") Then
ws.Cells(i, 2).Value = txtItem.Value
ws.Cells(i, 3).Value = txtQty.Value
ws.Cells(i, 4).Value = txtRate.Value
ws.Cells(i, 5).Value = txtQty.Value * txtRate.Value
ws.Cells(i, 9).Value = Date
ws.Cells(i, 10).Value = Time
ws.Cells(i, 8).Value = username
isFound = True
MsgBox "Record updated successfully!", vbInformation, "Success"
Exit For
End If
Next i
If Not isFound Then
MsgBox "Record not found or you don't have access to update it.", vbExclamation, "Error"
End If
End Sub
'yah Logout ka code hai
Private Sub cmdLogout_Click()
Dim logSheet As Worksheet
Dim logRow As Long
Dim loginTime As Date
Dim logoutTime As Date
Dim duration As String
Dim ws As Worksheet
Application.Visible = True ' Excel window visible karen
Set logSheet = ThisWorkbook.Sheets("Sheet3")
logRow = Val(UserForm1.Tag) ' Retrieve row number
If logRow > 0 Then
With logSheet
loginTime = .Cells(logRow, 3).Value + .Cells(logRow, 2).Value
logoutTime = Now
duration = Format(logoutTime - loginTime, "hh:mm:ss")
.Cells(logRow, 5).Value = duration ' Logout duration
.Cells(logRow, 6).Value = Date ' Logout Date
.Cells(logRow, 7).Value = Time ' Logout Time
End With
End If
' Reset sheet visibility
For Each ws In ThisWorkbook.Sheets
If ws.Name = "Sheet3" Or ws.Name = "Sheet2" Or ws.Name = "Sheet3" Then
ws.Visible = xlSheetVeryHidden ' Hide specific sheets
Else
ws.Visible = xlSheetVisible ' Show other sheets
End If
Next ws
' No sheet protection here (as per your request)
Application.Visible = False ' Excel window hide karen
Unload Me ' UserForm2 unload karen
UserForm1.Show vbModeless ' UserForm1 show karen
End Sub
'Data Entry ke baad DataEntry form ko clear krne ka code hai
Private Sub ResetForm()
txtItem.Value = ""
txtQty.Value = ""
txtRate.Value = ""
txtTotal.Value = ""
UserForm_Initialize ' Call initialize to get next Sr. No.
End Sub
'yah Excel on ka code hai
Private Sub cmdExcelOn_Click()
Application.Visible = True
End Sub
' Form ko direct cut krne pr background ke auto Data save and Sheet close ka code
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = 0 Then ' Close button (X) clicked
MsgBox "Thanks for Using Stock Entry Software...", vbExclamation, "Warning"
ThisWorkbook.Save
Unload Me
Application.Quit
End If
End Sub
'End of Userform2 ka code
Yah Userform3 as Reset Password ka code hai
'Yah Userform3 ka Code hai
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
' CloseMode = 0 indicates user clicked the Close button (X)
If CloseMode = 0 Then
MsgBox "Thanks for Using Password Reset Software...", vbExclamation, "Warning"
' Ensure only UserForm1 is displayed
ThisWorkbook.Save
Unload Me
Application.Quit
End If
End Sub
'Yah Go Back to Login Button Code hai
Private Sub CommandButton1_Click()
Unload Me
UserForm1.Show
End Sub
'yah Username type krte hi 3 security questions load hone ka code
Private Sub UserForm_Initialize()
lblMessage.Caption = "" ' Clear message label
txtAnswer1.Value = ""
txtAnswer2.Value = ""
txtAnswer3.Value = ""
txtNewPassword.Value = ""
txtNewPassword.Enabled = False ' Disable new password field initially
cmdReset.Enabled = False ' Disable Reset button initially
End Sub
'yah new password reset ka code hai, jab 3 security ans correct ho tab
Private Sub txtUsername_AfterUpdate()
Dim ws As Worksheet
Dim lastRow As Long
Dim username As String
Dim rowIndex As Long
Dim found As Boolean
' Initialize variables
username = Trim(txtUsername.Value)
If username = "" Then
lblMessage.Caption = "Please enter a username."
lblMessage.ForeColor = vbRed
Exit Sub
End If
' Reference the user database
Set ws = ThisWorkbook.Sheets("Sheet2")
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
found = False
' Search for the username in the database
For rowIndex = 2 To lastRow
If Trim(ws.Cells(rowIndex, 1).Value) = username Then
found = True
Exit For
End If
Next rowIndex
' If username is found, load questions
If found Then
lblQuestion1.Caption = "Question 1: " & ws.Cells(rowIndex, 4).Value
lblQuestion2.Caption = "Question 2: " & ws.Cells(rowIndex, 5).Value
lblQuestion3.Caption = "Question 3: " & ws.Cells(rowIndex, 6).Value
lblMessage.Caption = "Questions loaded successfully."
lblMessage.ForeColor = vbBlack
Else
lblQuestion1.Caption = "Question 1:"
lblQuestion2.Caption = "Question 2:"
lblQuestion3.Caption = "Question 3:"
lblMessage.Caption = "Username not found."
lblMessage.ForeColor = vbRed
End If
End Sub
'yah correct 3 ans check krne ka code hai
Private Sub cmdCheck_Click()
Dim ws As Worksheet
Dim lastRow As Long
Dim username As String
Dim rowIndex As Long
Dim found As Boolean
' Initialize variables
username = Trim(txtUsername.Value)
If username = "" Then
lblMessage.Caption = "Please enter your username."
lblMessage.ForeColor = vbRed
Exit Sub
End If
Set ws = ThisWorkbook.Sheets("Sheet2")
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
found = False
' Find the username in the database
For rowIndex = 2 To lastRow
If ws.Cells(rowIndex, 1).Value = username Then
found = True
Exit For
End If
Next rowIndex
' If username not found
If Not found Then
lblMessage.Caption = "Username not found."
lblMessage.ForeColor = vbRed
Exit Sub
End If
' Load questions
lblQuestion1.Caption = "Question 1: " & ws.Cells(rowIndex, 4).Value
lblQuestion2.Caption = "Question 2: " & ws.Cells(rowIndex, 5).Value
lblQuestion3.Caption = "Question 3: " & ws.Cells(rowIndex, 6).Value
' Validate answers
If StrComp(ws.Cells(rowIndex, 7).Value, Trim(txtAnswer1.Value), vbTextCompare) = 0 And _
StrComp(ws.Cells(rowIndex, 8).Value, Trim(txtAnswer2.Value), vbTextCompare) = 0 And _
StrComp(ws.Cells(rowIndex, 9).Value, Trim(txtAnswer3.Value), vbTextCompare) = 0 Then
lblMessage.Caption = "Your answers are correct. Now type a new password."
lblMessage.ForeColor = vbBlack
txtNewPassword.Enabled = True
cmdReset.Enabled = True
Else
lblMessage.Caption = "Incorrect answers. Please try again."
lblMessage.ForeColor = vbRed
txtAnswer1.Value = ""
txtAnswer2.Value = ""
txtAnswer3.Value = ""
End If
End Sub
'yah reset button ka code hai
Private Sub cmdReset_Click()
Dim ws As Worksheet
Dim username As String
Dim lastRow As Long
Dim rowIndex As Long
' Initialize variables
username = Trim(txtUsername.Value)
If txtNewPassword.Value = "" Then
lblMessage.Caption = "Please enter a new password."
lblMessage.ForeColor = vbRed
Exit Sub
End If
Set ws = ThisWorkbook.Sheets("Sheet2")
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
' Find the username in the database
For rowIndex = 2 To lastRow
If ws.Cells(rowIndex, 1).Value = username Then
ws.Cells(rowIndex, 2).Value = txtNewPassword.Value ' Update the password
lblMessage.Caption = "Password reset successfully! Redirecting to login..."
lblMessage.ForeColor = vbBlack
MsgBox "Your password has been reset. Please login again.", vbInformation
Me.Hide
UserForm1.Show
Exit Sub
End If
Next rowIndex
End Sub
'yah Profile Pic Update krne ka code hai
Private Sub cmdUpdatePic_Click()
Dim fd As FileDialog
Dim filePath As String
Dim ws As Worksheet
Dim username As String
Dim lastRow As Long
Dim rowIndex As Long
Dim found As Boolean
' Initialize variables
username = Trim(txtUsername.Value)
If username = "" Then
lblMessage.Caption = "Please enter your username before uploading a photo."
lblMessage.ForeColor = vbRed
Exit Sub
End If
' Open FileDialog to select a picture
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Title = "Select a Picture"
.Filters.Clear
.Filters.Add "Image Files", "*.jpg; *.jpeg; *.png; *.bmp; *.gif"
.AllowMultiSelect = False
' Show the dialog and get the file path
If .Show = -1 Then
filePath = .SelectedItems(1)
Else
lblMessage.Caption = "No file selected."
lblMessage.ForeColor = vbRed
Exit Sub
End If
End With
' Find the username in the database
Set ws = ThisWorkbook.Sheets("Sheet2")
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
found = False
For rowIndex = 2 To lastRow
If ws.Cells(rowIndex, 1).Value = username Then
found = True
Exit For
End If
Next rowIndex
If found Then
' Update the photo path in Column J
ws.Cells(rowIndex, 10).Value = filePath
lblMessage.Caption = "Photo uploaded successfully."
lblMessage.ForeColor = vbBlack
Else
lblMessage.Caption = "Username not found. Please try again."
lblMessage.ForeColor = vbRed
End If
End Sub
'End of Userform3 as Reset Password Code
