Excel VBA Certificate Maker Projects for Beginners To Advance Pradip VedantSri
1- Userform1 Code for Making Login Form
'yah Userform1 ka full 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 Excel Multi-Login Software.", vbExclamation, "Warning"
' Ensure only UserForm1 is displayed
ThisWorkbook.Save
Unload Me
Application.Quit
End If
End Sub
Private Sub cmdLogin_Click()
Dim ws As Worksheet
Dim logSheet As Worksheet
Dim lastRow As Long
Dim i As Long
Dim isAuthenticated As Boolean
Dim username As String, password As String
Dim role As String
' Retrieve input values
username = Trim(txtUsername.Value)
password = Trim(txtPassword.Value)
isAuthenticated = False
' Reference login sheet (Sheet4)
Set ws = ThisWorkbook.Sheets("Sheet4")
Set logSheet = ThisWorkbook.Sheets("Sheet5")
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
' Validate input
If username = "" Or password = "" Then
lblMessage.Caption = "Please enter both Username and Password."
lblMessage.ForeColor = vbRed
Exit Sub
End If
' Check credentials in the user database
For i = 2 To lastRow ' Assuming row 1 contains headers
If ws.Cells(i, 1).Value = username And ws.Cells(i, 2).Value = password Then
isAuthenticated = True
role = ws.Cells(i, 3).Value ' Role is in column C
Exit For
End If
Next i
If isAuthenticated Then
lblMessage.Caption = "Login Successful!"
lblMessage.ForeColor = vbGreen
Dim wsSheet As Worksheet
If role = "Admin" Then
' Admin Access: Show full Excel interface
MsgBox "Welcome Admin! You have full access.", vbInformation
Application.Visible = True
Application.DisplayAlerts = True
Application.EnableCancelKey = xlInterrupt
Application.CommandBars("Worksheet Menu Bar").Enabled = True
Application.CommandBars("Ribbon").Enabled = True
' Unhide all sheets for Admin
For Each wsSheet In ThisWorkbook.Sheets
wsSheet.Visible = xlSheetVisible
Next wsSheet
Else
' User Access: Hide Excel interface and restrict access
MsgBox "Welcome User! You have limited access.", vbInformation
Application.Visible = False ' Excel hidden for user
Application.DisplayAlerts = False
Application.EnableCancelKey = xlDisabled
Application.CommandBars("Worksheet Menu Bar").Enabled = False
Application.CommandBars("Ribbon").Enabled = False
' Hide sensitive sheets for User
For Each wsSheet In ThisWorkbook.Sheets
If wsSheet.Name = "Sheet3" Or wsSheet.Name = "Sheet4" Or wsSheet.Name = "Sheet5" Then
wsSheet.Visible = xlSheetVeryHidden
Else
wsSheet.Visible = xlSheetVisible
End If
Next wsSheet
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
' Open UserForm2 and close UserForm1
Me.Hide
UserForm2.Show vbModeless
Else
lblMessage.Caption = "Invalid Username or Password."
lblMessage.ForeColor = vbRed
End If
End Sub
Private Sub cmdForget_Click()
Me.Hide
UserForm3.Show vbModeless
End Sub
'End of Userform1 Code
2- Excel VBA Userform2 Code for Certificate Maker Project
'yah Userform2 ka code hai
' Excel off Button code
Private Sub cmdExcelOff_Click()
Application.Visible = False
End Sub
' Save Workbook in background if Cut this form
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = 0 Then ' Close button (X) clicked
MsgBox "Thanks for Using Certificate Maker Software...", vbExclamation, "Warning"
ThisWorkbook.Save
Unload Me
Application.Quit
End If
End Sub
' Logout button code
Private Sub cmdLogout_Click()
Dim logSheet As Worksheet
Dim logRow As Long
Dim loginTime As Date
Dim logoutTime As Date
Dim duration As String
Application.Visible = True
Set logSheet = ThisWorkbook.Sheets("Sheet5")
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
.Cells(logRow, 6).Value = Date
.Cells(logRow, 7).Value = Time
End With
End If
For Each wsSheet In ThisWorkbook.Sheets
If wsSheet.Name = "Sheet3" Or wsSheet.Name = "Sheet4" Or wsSheet.Name = "Sheet5" Then
wsSheet.Visible = xlSheetVeryHidden
Else
wsSheet.Visible = xlSheetVisible
End If
Next wsSheet
Application.Visible = False
Unload Me
UserForm1.Show vbModeless
End Sub
' automatic load data related Enroll no
Private Sub UserForm_Initialize()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet3")
Dim lastRow As Long
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
' ComboEnroll and comboGrade
Me.comboEnroll.Clear
Me.comboGrade.Clear
For i = 2 To lastRow
Me.comboEnroll.AddItem ws.Cells(i, 1).Value
If Not IsEmpty(ws.Cells(i, 5).Value) Then
Me.comboGrade.AddItem ws.Cells(i, 5).Value
End If
Next i
' Current Date
Me.txtDate.Value = Format(Date, "dd-mm-yyyy")
' Unique Certificate Number Generate
Me.txtCertificate.Value = GenerateTemporaryCertificateNumber()
End Sub
' Code to call Certificate no in txtCertificate
Private Function GenerateTemporaryCertificateNumber() As String
' Temporary Certificate Number Generate ???? (Sheet2 ??? Save ???? ????)
GenerateTemporaryCertificateNumber = Format(Now, "yyyymmddhhmmss") & Int((1000) * Rnd)
End Function
' code to create unique certificate no
Private Function GenerateUniqueCertificateNumber() As String
Dim ws As Worksheet
Dim newCertificateNumber As String
Dim lastRow As Long
Dim isUnique As Boolean
' Certificate Numbers ?? Sheet2 ??? Track ????
Set ws = ThisWorkbook.Sheets("Sheet2")
lastRow = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row
Do
' Randomly Unique Number Generate ????
newCertificateNumber = Format(Now, "yyyymmddhhmmss") & Int((1000) * Rnd)
' Check ???? ?? Number ???? ?? ????? ? ??
isUnique = Application.CountIf(ws.Columns(2), newCertificateNumber) = 0
Loop Until isUnique
' ???? Save ?? ????? ??? Sheet2 ??? ??? ????
ws.Cells(lastRow + 1, 2).Value = newCertificateNumber
GenerateUniqueCertificateNumber = newCertificateNumber
End Function
' code to match Data related when Select Enroll No
Private Sub comboEnroll_Change()
Dim ws As Worksheet
Dim rowIndex As Variant
' Sheet3 set karein
Set ws = ThisWorkbook.Sheets("Sheet3")
' comboEnroll.Value ko match karein
On Error Resume Next
rowIndex = Application.Match(Me.comboEnroll.Value, ws.Columns(1), 0)
On Error GoTo 0
If Not IsError(rowIndex) Then
' Agar match milta hai to related values set karein
Me.txtCourse.Value = ws.Cells(rowIndex, 2).Value
Me.txtElement.Value = ws.Cells(rowIndex, 3).Value
Me.txtDuration.Value = ws.Cells(rowIndex, 4).Value
Else
' Agar match nahi milta hai to error message aur fields clear karein
MsgBox "Invalid Selection. Please choose a valid enrollment number.", vbExclamation, "Error"
Me.txtCourse.Value = ""
Me.txtElement.Value = ""
Me.txtDuration.Value = ""
End If
End Sub
' code to upload Picture
Private Sub cmdUpload_Click()
On Error Resume Next
Dim imgPath As String
imgPath = Application.GetOpenFilename("Image Files (*.jpg; *.png), *.jpg; *.png", , "Select an Image")
If imgPath <> "False" Then
Me.imgPicture.Picture = LoadPicture(imgPath)
Else
MsgBox "No image selected.", vbExclamation, "Image Upload"
End If
On Error GoTo 0
End Sub
' code to Entry, Save Pdf in Certificate Folder in C drive, Print
Private Sub cmdEntry_Click()
Dim ws As Worksheet
On Error GoTo ErrHandler ' Error handling setup
Set ws = ThisWorkbook.Sheets("Sheet1")
' Sheet1 mein data save karein
ws.Range("C3").Value = Me.comboEnroll.Value
ws.Range("I3").Value = Me.txtCertificate.Value
ws.Range("A11").Value = Me.txtName.Value
ws.Range("A14").Value = Me.txtCourse.Value
ws.Range("A24").Value = Me.comboGrade.Value
ws.Range("A19").Value = Me.txtElement.Value
ws.Shapes("Shape1").TextFrame.Characters.Text = Me.txtDuration.Value
ws.Shapes("Shape2").TextFrame.Characters.Text = Me.txtDate.Value
' Image Insert karein (Error Handling ka saath)
If Not Me.imgPicture.Picture Is Nothing Then
Dim imgTempPath As String
imgTempPath = Environ("Temp") & "\tempImage.jpg"
SavePicture Me.imgPicture.Picture, imgTempPath
' Existing Shape3 ko replace karein
Dim shp As Shape
For Each shp In ws.Shapes
If shp.Name = "Shape3" Then
shp.Delete
Exit For
End If
Next shp
' Shape3 ko recreate karein
ws.Shapes.AddPicture imgTempPath, _
msoFalse, msoCTrue, 420, 230, 101, 130
ws.Shapes(ws.Shapes.Count).Name = "Shape3"
End If
MsgBox "Entry Saved!", vbInformation
' Save Data in Sheet and as PDF in Certificate folder in c Drive
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")
Dim fileName As String
fileName = "C:\Certificate\" & Me.txtName.Value & "_" & Me.txtDate.Value & "_" & Me.txtCourse.Value & ".pdf"
' PDF Save karein
ws1.Range("A1:K35").ExportAsFixedFormat Type:=xlTypePDF, fileName:=fileName, Quality:=xlQualityStandard
ws1.PrintOut
' Certificate Number ko Sheet2 mein save karein
Dim lastRow As Long
lastRow = ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row + 1
ws2.Cells(lastRow, 1).Value = Me.comboEnroll.Value
ws2.Cells(lastRow, 2).Value = Me.txtCertificate.Value
ws2.Cells(lastRow, 3).Value = Me.txtName.Value
ws2.Cells(lastRow, 4).Value = Me.txtCourse.Value
ws2.Cells(lastRow, 5).Value = Me.comboGrade.Value
ws2.Cells(lastRow, 6).Value = Me.txtDuration.Value
ws2.Cells(lastRow, 7).Value = Me.txtDate.Value
ws2.Cells(lastRow, 8).Value = Format(Now, "hh:mm:ss")
MsgBox "PDF Saved and Data Updated!", vbInformation
' Form clear karein aur nayi Certificate Number generate karein
Me.comboEnroll.Value = ""
Me.txtCertificate.Value = Format(Val(Me.txtCertificate.Value) + 1, "0000") ' Increment certificate number
Me.txtName.Value = ""
Me.txtCourse.Value = ""
Me.comboGrade.Value = ""
Me.txtElement.Value = ""
Me.txtDuration.Value = ""
'Me.txtDate.Value = ""
Set Me.imgPicture.Picture = Nothing
Me.comboEnroll.SetFocus ' Pehla field active karein
Exit Sub
ErrHandler:
MsgBox "An error occurred: " & Err.Description, vbCritical, "Error"
Exit Sub
End Sub
' Exit Button code
Private Sub cmdExit_Click()
ThisWorkbook.Save
Unload Me
Application.Quit
End Sub
' Excel On Button Code
Private Sub cmdExcel_Click()
Application.Visible = True
End Sub
'End of Userform2 Code
3- Excel VBA UserForm3 Code How To Create Reset Password
'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
Private Sub CommandButton1_Click()
Unload Me
UserForm1.Show
End Sub
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
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("Sheet4")
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 = vbGreen
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
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("Sheet4")
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 = vbGreen
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
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("Sheet4")
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 = vbGreen
MsgBox "Your password has been reset. Please login again.", vbInformation
Me.Hide
UserForm1.Show
Exit Sub
End If
Next rowIndex
End Sub
'End of Userform3 Code
4- ThisWorkBook Code in Excel VBA Projects
'Yah ThisWorkbook ka Code hai
Private Sub Workbook_Open()
' Hide sensitive sheets (Sheet3, Sheet4, Sheet5) by default
ThisWorkbook.Sheets("Sheet3").Visible = xlSheetVeryHidden
ThisWorkbook.Sheets("Sheet4").Visible = xlSheetVeryHidden
ThisWorkbook.Sheets("Sheet5").Visible = xlSheetVeryHidden
' Hide Excel and show the login form (UserForm1)
Application.Visible = False
UserForm1.Show vbModeless
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim logSheet As Worksheet
Dim lastRow As Long
Dim logoutRow As Long
Dim logoutTime As Double
' Reference the log sheet (Sheet5)
Set logSheet = ThisWorkbook.Sheets("Sheet5")
lastRow = logSheet.Cells(logSheet.Rows.Count, 1).End(xlUp).Row
' Find the last logged-in row marked as "In Progress"
For logoutRow = lastRow To 2 Step -1
If logSheet.Cells(logoutRow, 5).Value = "In Progress" Then
' Update logout details
logSheet.Cells(logoutRow, 6).Value = Date ' Logout Date
logSheet.Cells(logoutRow, 7).Value = Time ' Logout Time
' Calculate session duration
logoutTime = DateDiff("n", _
logSheet.Cells(logoutRow, 2).Value + logSheet.Cells(logoutRow, 3).Value, _
logSheet.Cells(logoutRow, 6).Value + logSheet.Cells(logoutRow, 7).Value)
logSheet.Cells(logoutRow, 5).Value = logoutTime & " minutes" ' Update duration
Exit For
End If
Next logoutRow
' Ensure Excel is visible and reset interface before closing
Application.Visible = True
Application.DisplayAlerts = True
Application.CommandBars("Worksheet Menu Bar").Enabled = True
Application.CommandBars("Ribbon").Enabled = True
' Save changes and close workbook
ThisWorkbook.Save
End Sub
'End of ThisWorkBook Code
