Restrict viewing access to an Excel worksheet - excel

I thought this would be a readily used function in Excel but it's surprisingly difficult to implement a simple process of restricting access to specific worksheets within a larger workbook.
There's a few methods that prompt an initial password to open various versions of the same workbook. But I want to keep the workbook identical for all users but restrict access to certain sheets. Surely there's a password protect function that requires the user to enter a password to view a sheet. Rather than create multiple versions of the same workbook based on different users.
I have tried the following but it doesnt prompt a password to access the sheet
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim MySheets As String, Response As String
Dim MySheet As Worksheet
MySheet = "COMMUNICATION"
If ActiveSheet.Name = MySheet Then
ActiveSheet.Visible = False
Response = InputBox("Enter password to view sheet")
If Response = "MyPass" Then
Sheets(MySheet).Visible = True
Application.EnableEvents = False
Sheets(MySheet).Select
Application.EnableEvents = True
End If
End If
Sheets(MySheet).Visible = True
End Sub
Am I doing this right?

It sounds like according to the comments that this isn't as much as a security issue as it is a convenience issue. So please bear in mind when considering implementing this into your project that this is easily breakable if there is any malicious intent to gain unauthorized access.
First, I would recommend a common landing zone. A main worksheet that is displayed immediately after opening a workbook. To do this, we would use the Workbook_Open() event and activate a sheet from there.
This can be a hidden sheet if desired, that will be up to you.
Option Explicit
Private lastUsedSheet As Worksheet
Private Sub Workbook_Open()
Set lastUsedSheet = Me.Worksheets("MainSheet")
Application.EnableEvents = False
lastUsedSheet.Activate
Application.EnableEvents = True
End Sub
Next, we should decide on what should occur when there's an attempt to access a new sheet. In the below method, once a sheet is activated it will automatically redirect the user back to the last used sheet until a successful password attempt has been made.
We can track the last used sheet in a module-scoped variable, which in this example will be named lastUsedSheet. Any time a worksheet is successfully changed, this variable will be set to that worksheet automatically - this way when when someone attempts to access another sheet, it will redirect them back to the prior sheet until the password is successfully entered.
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
On Error GoTo SafeExit
Application.EnableEvents = False
' Error protection in case lastUsedSheet is nothing
If lastUsedSheet Is Nothing Then
Set lastUsedSheet = Me.Worksheets("MainSheet")
End If
' Allow common sheets to be activated without PW
If Sh.Name = "MainSheet" Then
Set lastUsedSheet = Sh
Sh.Activate
GoTo SafeExit
Else
' Temporarily send the user back to last sheet until
' Password has been successfully entered
lastUsedSheet.Activate
End If
' Set each sheet's password
Dim sInputPW As String, sSheetPW As String
Select Case Sh.Name
Case "Sheet1"
sSheetPW = "123456"
Case "Sheet2"
sSheetPW = "987654"
End Select
' Create a loop that will keep prompting password
' until successful pw or empty string entered
Do
sInputPW = InputBox("Please enter password for the " & _
"worksheet: " & Sh.Name & ".")
If sInputPW = "" Then GoTo SafeExit
Loop While sInputPW <> sSheetPW
Set lastUsedSheet = Sh
Sh.Activate
SafeExit:
Application.EnableEvents = True
If Err.Number <> 0 Then
Debug.Print Time; Err.Description
MsgBox Err.Description, Title:="Error # " & Err.Number
End If
End Sub
Side note, disabling events is necessary due to the fact that your Workbook_SheetActivate event will continue to fire after a successful sheet change.
Preventing file type changes during SaveAs1
You can further protect the accidental removal of VBA code by restricting the file save type. This can be accomplished using the Workbook_BeforeSave() event. The reason this is a potential problem is that saving as a non-macro enabled workbook will erase the code, which will prevent the password protection features you just implemented above.
First, we need to check if this is a Save or SaveAs. You can accomplish this using the Boolean property SaveAsUI that is included with the event itself. If this value is True, then it's a SaveAs event - which means we need to perform additional checks to ensure that the file type isn't accidentally changed from the save dialog box. If the value is False, then this is a normal save, and we can bypass these checks because we know the workbook will be saved as type .xlsm.
After this initial check, we will display the dialog box using Application.FileDialog().Show.
Afterwards, we will check if the user canceled the operation .SelectedItems.Count = 0 or clicked Save. IF user clicked cancel, then we simply set Cancel = True and the workbook will not save.
We proceed to check the type of extension selected by the user using this line:
If Split(fileName, ".")(UBound(Split(fileName, "."))) <> "xlsm" Then
This will split the file path by a period ., and will grab the last instance of the period (UBound(Split(fileName, "."))) in the event a file name may contain additional periods. If the extension does not match xlsm, then we abort the save operation.
Finally, after all checks passed, you can save the document:
Me.SaveAs .SelectedItems(1), 52
Since we already saved it with the above line, we can go ahead and set Cancel = True and exit the routine.
The full code (to be placed in the Worksheet obj module):
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
On Error GoTo SafeExit
If SaveAsUI Then
With Application.FileDialog(msoFileDialogSaveAs)
.Show
If .SelectedItems.Count = 0 Then
Cancel = True
Else
Dim fileName$
fileName = .SelectedItems(1)
If Split(fileName, ".")(UBound(Split(fileName, "."))) <> "xlsm" Then
MsgBox "You must save this as an .xlsm document. Document has " & _
"NOT been saved", vbCritical
Cancel = True
Else
Application.EnableEvents = False
Application.DisplayAlerts = False
Me.SaveAs .SelectedItems(1), 52
Cancel = True
End If
End If
End With
Else
Exit Sub
End If
SafeExit:
Application.EnableEvents = True
Application.DisplayAlerts = True
If Err.Number <> 0 Then
Debug.Print Time; Err.Description
MsgBox Err.Description, Title:="Error # " & Err.Number
End If
End Sub
1 Shoutout to PatricK for the suggestion

If you want to restrict access to a worksheet, you can just hide it:
ActiveWorkbook.Sheets("YourWorkSheet").Visible = xlSheetVeryHidden

I concur with Mathieu Guindon that any VBA attempt to "Restrict viewing access to an Excel worksheet" will be flimsy as explained by Mathieu Guindon. Moreover, If the file is opened with Excel option Macro security level other than the lowest, any VBA code including this is bound to fail.
However just for shake of simplicity I prefer to use workbook open event and Sheet Activate of the restricted sheet. Using Workbook Sheet Activate event will trigger password prompt even during switching between sheets by user with viewing access.
Private Sub Workbook_Open()
Sheets("COMMUNICATION").Visible = xlSheetHidden
End Sub
Public ViewAccess As Boolean 'In restricted sheet's activate event
Private Sub Worksheet_Activate()
If ViewAccess = False Then
Me.Visible = xlSheetHidden
response = Application.InputBox("Password", xTitleId, "", Type:=2)
If response = "123" Then
Me.Visible = xlSheetVisible
ViewAccess = True
End If
End If
End Sub

Related

How to write code to test a cell for specific data, and if that data is present, don't run the macro. If not present, then run macro?

I am trying to test a cell for specific data. If it contains that data, I do not want my code to run (because that would leave my worksheet and workbook Unprotected). If the cell contains data that does not match the test specifics, then I want the code to run. My code is to unprotect the active workbook, then unprotect the active worksheet, then fill the value of cell N41 as the "sheet name", then protect the active worksheet, then protect the active workbook. I want to add the test to the top of the code to avoid security failures.
The data that I want to test the cell for is:
The cell does not contain more than 31 characters (including spaces between charaters)
The cell does not contain any of the following characters: \ / : ? * [ or ]
The cell is not blank (empty)
If any of the above data/characters are in the cell I want the code to not run and leave my password protection in place for both the protected worksheet and protected workbook.
If the cell contains less than 31 characters (including spaces), does not contain any of the unwanted characters, and has at least 1 character in it (not a blank cell) then I want the code to run. Any help would be greatly appreciated.
Private Sub CommandButton16_Click()
ThisWorkbook.Unprotect Password:="Password1"
ActiveSheet.Unprotect Password:="Password2"
ActiveSheet.Name = Range("N41").Value
ActiveSheet.Protect Password:="Password2"
ThisWorkbook.Protect Password:="Password1"
End Sub
I guess the real question is "How to check if some value is the correct name for a worksheet?" in order to minimize the period when the document is not protected, and to eliminate an error when renaming.
From the full list of naming conventions we can learn two additional rules. The name shouldn't be "History" and it shouldn't begin or end with an apostrophe '. Also, there shouldn't be other sheets with that name.
In my opinion, the easiest way to accomplish the main task is to wrap renaming with On Error statements.
Private Sub CommandButton_Click()
Const BookPass = "Password1"
Const SheetPass = "Password2"
Dim NewName as String
Dim ErrCode&, ErrDesc$, ErrMessage$
NewName = Range("N41").Value
With ThisWorkbook
.Unprotect BookPass
With ActiveSheet
.Unprotect SheetPass
On Error Resume Next
' ------ Main Part -------
.Name = NewName
' ------------------------
ErrCode = Err.Number
ErrDesc = Err.Description
On Error GoTo 0
.Protect SheetPass
End With
.Protect BookPass
End With
If ErrCode <> 0 Then
ErrMessage = "NewName=" & NewName & vbNewLine & _
"Error=" & ErrCode & vbNewLine & _
"Description: " & ErrDesc
MsgBox ErrMessage, vbCritical
End If
End Sub
p.s. I suppose, this code will be placed in the worksheet object module. In this case, it is better to replace ActiveSheet with Me for readability.
If you are prepared to weaken the Workbook protection, you can add use this code when protecting the Workbook.
Your code can then change the sheet name without unprotecting the WorkBook, but so can your users.
ActiveWorkbook.Protect Password:="Password1", Structure:=False
The WorkSheet can be protected to allow changes from your code but not by your users.
This way you protect the WorkSheet and never have to unprotect it.
ActiveSheet.Protect Password:="Password2", UserInterfaceOnly:=True
In your code, you can set a boolean value to true if a test passes and exit the sub with a custom message if a test fails. Then test the boolean value and if it is true, unprotect the Workbook, make the update and reprotect the Workbook.
Option Explicit
Private Sub ProtectAll()
ActiveWorkbook.Protect Password:="Password1"
' ActiveWorkbook.Protect Password:="Password1", Structure:=False
'Optional: Allow changes to sheet names and order, not ideal
'but allows you to not have to protect and unprotect the workbook
ActiveSheet.Protect Password:="Password2", UserInterfaceOnly:=True
'Allow changes to the active worksheet by VBA code, remains protected via the UI
End Sub
Private Sub UnprotectAll()
ActiveSheet.Unprotect Password:="Password2"
ThisWorkbook.Unprotect Password:="Password1"
End Sub
Private Sub ProtectWB()
ActiveWorkbook.Protect Password:="Password1"
End Sub
Private Sub UnprotectWB()
ThisWorkbook.Unprotect Password:="Password1"
End Sub
Private Sub Change()
Dim CellValue As String
Dim OKtoChange As Boolean
Dim ErrorMessage As String
CellValue = vbNullString
OKtoChange = False
CellValue = ActiveSheet.Range("N41").Value
If Len(CellValue) < 32 Then
OKtoChange = True
Else
ErrorMessage = "The WorkSheet name is more than 31 characters."
GoTo ErrorHandler
End If
'Other tests here to set the OKtoChange variable based on results
'If any test fails the code exits
If OKtoChange = True Then
Call UnprotectWB
ActiveSheet.Name = CellValue
Call ProtectWB
End If
Exit Sub
ErrorHandler:
MsgBox "Invalid name for the WorkSheet" & vbLf & ErrorMessage, vbCritical, "Invalid name"
End Sub

Excel VBA - Can't unhide worksheets

I have a log of incoming / outgoing test samples which I've added code to kick users out if no worksheet change is detected for more than 5 minutes (https://excelribbon.tips.net/T008192_Forcing_a_Workbook_to_Close_after_Inactivity.html). In order to make sure users have macros enabled, I have a worksheet called "Splash Screen" which is the only worksheet visible when the workbook is first opened (all other worksheets are set to xlVeryHidden).
The code I have to hide/unhide worksheets looks simple and works perfectly if the workbook is closed manually, but not if forced to close via the timeout. This is called near the end of the Workbook_BeforeClose procedure:
Dim ws As Worksheet
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
Select Case ws.Name
Case Is = "Splash Screen"
ws.Visible = xlSheetVisible
Case Else
ws.Visible = xlSheetVeryHidden
End Select
Next
Application.ScreenUpdating = True
After this code block has run, there is no change to the visibility of the worksheets. Everything which was hidden is still hidden, everything that was visible is still visible, everything that was veryhidden is still veryhidden.
The worksheets are locked, but I've tried unlocking them before hiding them and that doesn't help. I've ensured events are enabled, screenupdating is true, errors are not set to "Resume Next", but none of it seems to help. Any suggestions?
Edited to add more code:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
'Checks for missing data in rows to be locked - if missing, user is prompted to enter
'User can optionally cancel closing the document to enter missing data
Call DataMissing(Cancel) 'If data missing and user wishes to enter, Cancel = True
If Cancel Then Exit Sub 'If Cancel = True, exit without further action
'Locks rows which were changed and Logs changes (if any were made)
Call LockRows
Call EmailPM("Delivered")
Call Internal_LockRows
If Not Not LoggedRows Then
Call LogChanges
Call EmailPM("Edited")
End If
If Not Not Internal_LoggedRows Then
Call Internal_LogChanges
End If
Call EmailPM("Internal")
'If changes have been made to live samples, updates lab manager
If Not Not LiveRows Then Call EmailPM("Live")
If Not Not Internal_LiveRows Then Call EmailPM("Internal_Live")
'Clears all filters on all sheets
Dim ws As Worksheet
On Error Resume Next
For Each ws In ThisWorkbook.Worksheets
ws.AutoFilter.ShowAllData
Next ws
On Error GoTo 0
'Selects MainLab sheet before closing
MainLab.Select
'Ensures TimeStop and RowID will fire on worksheet change
Application.EnableEvents = True
Call TimeStop
'Hides sheets (only unhides if macros are enabled)
Call HideSheets
'Stores who closed the file to log
LogToFile (ThisWorkbook.Name & "; " & OpenState & "; closed by; " & Environ("Username") & "; " & Format(Now, "yyyy-mm-dd hh:mm:ss"))
End Sub
Sub TimeSetting()
'Sets CloseTime to a set time in the future, then runs SavedAndClose
CloseTime = Now + TimeValue("00:00:30") 'Timeout after 5 mins of inactivity
On Error Resume Next
Application.OnTime earliesttime:=CloseTime, procedure:="SavedAndClose", Schedule:=True
On Error GoTo 0
End Sub
Sub TimeStop()
'A sub to stop the timer ticking down
On Error Resume Next
Application.OnTime earliesttime:=CloseTime, procedure:="SavedAndClose", Schedule:=False
On Error GoTo 0
End Sub
Sub SavedAndClose()
'Closes the workbook and saves when called
Application.CutCopyMode = False 'Empties the clipboard to avoid the potential "keep the clipboard" alert
LogToFile (ThisWorkbook.Name & "; " & OpenState & "; auto-closed; " & Environ("Username") & "; " & Format(Now, "yyyy-mm-dd hh:mm:ss"))
ThisWorkbook.Close savechanges:=True
End Sub
The main reason this does not work is ThisWorkbook.saved = True. Essentially this is saying I've already saved so don't bother prompting me to save when I close. Problem is you haven't saved at the time you are calling close.
Here is a basic example of the setup. You want to: 1. Hide the sheets, 2. Save the document, 3. Close.
Sub HideSheets()
' Insert your hide sheet code here
Sheet2.Visible = xlSheetHidden ' Test line to hide one sheet
ThisWorkbook.Save
End Sub
Sub ShutDown()
Call HideSheets
ThisWorkbook.Close
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
'This doesn't do much on the automated close, because you've saved already.
Call HideSheets
End Sub

Why does my sub not work when it runs fine in immediate window excel vba

I've been trying to get the typical hide sheets/unhide sheets code to work for encouraging Macro enabling. Since I lock down saving, I needed to do it slightly differently than putting it in the Workbook_BeforeClose Sub as usually is done.
But...my hide sub
Sub HideSheets()
'Error Handling when workbook is unprotected.
On Error GoTo EH
'Unprotect the workbook to allow conditional formatting changes.
ThisWorkbook.Sheets("Field Service Report").Unprotect Password:="x"
ThisWorkbook.Sheets("Prompt").Unprotect Password:="x"
'Main Sub Code
Application.EnableCancelKey = xlDisabled
Sheets("Prompt").Visible = xlSheetVisible
Sheets("Field Service Report").Visible = xlSheetVeryHidden
Application.EnableCancelKey = xlInterrupt
'Reprotect worksheet before ending sub.
ThisWorkbook.Sheets("Field Service Report").Protect Password:="x", UserInterfaceOnly:=True
ThisWorkbook.Sheets("Prompt").Protect Password:="x"
Exit Sub
EH:
Call EH
Resume Next
End Sub
and my unhide sub
Sub UnhideSheets()
'Error Handling
On Error GoTo EH
'Unprotect the workbook to allow conditional formatting changes.
ThisWorkbook.Sheets("Field Service Report").Unprotect Password:="x"
ThisWorkbook.Sheets("Prompt").Unprotect Password:="x"
'Main Sub Code
Application.EnableCancelKey = xlDisabled
Sheets("Field Service Report").Visible = xlSheetVisible
Sheets("Prompt").Visible = xlSheetVeryHidden
Application.EnableCancelKey = xlInterrupt
'Reprotect worksheet before ending sub.
ThisWorkbook.Sheets("Field Service Report").Protect Password:="x", UserInterfaceOnly:=True
ThisWorkbook.Sheets("Prompt").Protect Password:="x"
Exit Sub
EH:
Call EH
Resume Next
End Sub
....works fine when called form the immediate window. Sheets hide and unhide appropriately.
But, when I step through the sub it doesn't actually do anything. The idea is to set the sheets to the "prompt" sheet before saving, save, then revert to usable after saving. But I can't even see if that code is working correctly (it appears to) because stepping through the actual hide/unhide subs doesn't do anything.
Edit: No errors, just doesn't change any settings to hide or unhide sheets.
Thoughts?
Edit: So given the comments below, my subs work when run from the immediate window and when stepped through via debugger. They hide and unhide the worksheets appropriately. So, the only thing that can be wrong is the code that calls these subs. So, here are two more subs. One is the button code for a save button, and the other is the Workbook_BeforeSave Sub.
Sub Save_Form()
'Error Handling ...
On Error GoTo EH
'Unprotect the workbook ...
ThisWorkbook.Sheets("Field Service Report").Unprotect Password:="x"
'Variable to disable any other save but this button.
Module1.SaveChk = 1
'Code to automatically save a copy ...
Module1.UserPath = Environ("USERPROFILE")
Module1.Path = UserPath & "\Desktop\"
If Module1.EditChk = "Y" Then
Module1.SaveName = "FSR Master"
Else
Module1.SaveName = Range("AF6").Value
End If
ThisWorkbook.SaveAs _
Filename:=Path & SaveName & ".xlsm", _
FileFormat:=52
If Module1.SaveError <> 1 Then
'User Display of Save Success
MsgBox "Filename = " & SaveName & vbNewLine _
& "File is saved to your desktop."
Else
Module1.SaveError = 0
End If
'Reset SaveChk variable
Module1.SaveChk = 0
'Reprotect Worksheet
ThisWorkbook.Sheets("Field Service Report").Protect Password:="x", UserInterfaceOnly:=True
Exit Sub
EH:
Call ErHa
Resume Next
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'Error Handling ...
On Error GoTo EH
'Save Initiation Check
If Module1.SaveChk <> 1 Then
Cancel = True
MsgBox "Please Use Form Save Button", vbOKCancel + vbExclamation, "SAVE CANCELLED"
Exit Sub
End If
If Module1.EditChk <> "Y" Then 'Skips the whole block if EditChk = Y
'Create the final range of cells for checking
Set Module1.Required = Application.Union(Module1.Fixed, Module1.Drive, Module1.Stage)
'Check if all required cells are filled in
If WorksheetFunction.CountA(Module1.Required) < Module1.Required.Count Then
Cancel = True
MsgBox "Please Completed Shaded Cells!", vbOK + vbExclamation, "SAVE CANCELLED"
Module1.SaveError = 1
Else
'Set the report date before saving
Application.EnableEvents = False
Range("AE59") = Format(Now(), "mm-dd-yyyy hh:mm:ss AM/PM")
Application.EnableEvents = True
End If
End If
'Renable Macro Splash Screen Before Save
Call HideSheets
Exit Sub
EH:
Call ErHa
Resume Next
End Sub

Excel - Limit view of worksheets to certian users

I have an excel workbook containing several worksheets.
What I want to do is have a mechanism like a user form or something where the user would authenticate to one of several possible users.
Based on the username supplied I want to display certain worksheets and hide other sheets, and block the user from accessing worksheets they should not be able to view.
Has anyone done something like this in Excel?
Any thoughts are appreciated
Sean
I actually enjoyed the task of typing this one up. Keep in mind, VBE is not protected in this code so you may want to add some protection, but this should do what you need.
You should also create a generic Login worksheet. This would be the only sheet open before a password is entered. This is essential as you are unable to hide every sheet without throwing an error. (You need to have 1 visible sheet).
WARNING: This code is mildly tested. You are responsible for any loss of data for using the below code, such as (but not limited to) forgetting a password. You have been warned!!!!
1. Open the Workbook, then make a Call to GetLogin
Option Explicit
Private Sub Workbook_Open()
GetLogin 1
End Sub
2. The Login Code
Private Sub GetLogin(ByVal AttemptNumber As Integer)
Dim Sheet As Worksheet
With ThisWorkbook.Worksheets("Login")
.Visible = xlSheetVisible
.Activate
End With
For Each Sheet In ThisWorkbook.Sheets
If Not Sheet.Name = "Login" Then
Sheet.Visible = xlSheetVeryHidden
End If
Next Sheet
Dim Password As String
Password = Application.InputBox("Please enter your password")
Select Case Password
Case "Ma$terPas$"
For Each Sheet In ThisWorkbook.Sheets
Sheet.Visible = xlSheetVisible
Next Sheet
ThisWorkbook.Worksheets(1).Activate 'For when you hide login sheet
Case "Oth3Rpa$$"
With ThisWorkbook
.Worksheets(1).Visible = xlSheetVisible
End With
ThisWorkbook.Worksheets(1).Activate 'For when you hide login sheet
Case Else
If AttemptNumber <= 3 Then
If MsgBox("You entered an incorrect password", vbRetryCancel, "Attempt # " & AttemptNumber) = vbRetry Then
AttemptNumber = AttemptNumber + 1
GetLogin AttemptNumber
Else
ThisWorkbook.Saved = True
ThisWorkbook.Close
End If
Else
ThisWorkbook.Saved = True
ThisWorkbook.Close
End If
End Select
ThisWorkbook.Worksheets("Login").Visible = xlSheetHidden
End Sub
3. Close the Workbook
Private Sub Workbook_BeforeClose(Cancel As Boolean)
If ThisWorkbook.Saved = False Then
If MsgBox("Would you like to save?", vbYesNo) = vbYes Then
ThisWorkbook.Save
End If
End If
Dim Sheet As Worksheet
With ThisWorkbook.Worksheets("Login")
.Visible = xlSheetVisible
.Activate
End With
For Each Sheet In ThisWorkbook.Sheets
If Not Sheet.Name = "Login" Then
Sheet.Visible = xlSheetVeryHidden
End If
Next Sheet
'Prevent from being asked to save the fact you just hid the sheets
ThisWorkbook.Saved = True
End Sub
Ensure that the Workbook_Open and Workbook_Close are in your Workbook's Module.
You could probably achieve this by using the Auto_Open event
Function Auto_Open()
Select Case True
Case InStr(Application.UserName, "Dan Smith") > 0
ActiveWorkbook.Sheets(1).Visible = xlSheetVeryHidden
Case InStr(Application.UserName, "Jon Doe") > 0
ActiveWorkbook.Sheets(1).Visible = True
End Select
End Function
Of course this would take a lot of work considering you'd have to find out everyone's usernames and then the sheets that you want to hide from them, but that's what I thought of

Login attempts and error handling in VBA Excel

I have been trying to fix a login problem but I cannot find a solution. When both login and pass fail, an error message starts a countdown without letting the user manifest another opinion.
QUESTION 1: Can anyone please make the necessary corrections without altering too much the given code structure and explain?
QUESTION 2: What code would turn the "User1" text into bold at the moment the access is granted?
QUESTION 3: What command would disable the "X" on the top right-hand corner of the msg form?
Thank you in advance
Here it is what I could do
¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨
Private Sub BtOK_Click()
Dim User1 As String
Dim count As Integer
count = 3
MM:
If EDBoxlogin.Value = "admin" And EDBoxpass.Value = "1234" Then
User1 = Application.UserName
MsgBox "welcome" & User1 & " !", vbExclamation, "Access Granted"
Sheets("Plan1").Visible = xlSheetVisible
Unload Me
Else
If EDBoxlogin.Value = "" Or EDBoxpass.Value = "" Then
MsgBox "Please, fill in the fiels 'login' and 'pass'", vbExclamation + vbOKOnly, "Access denied : incomplete information"
Else
If count >= 0 Then
MsgBox "Login and pass are incorrect! You have " & count & " more trial(s)", vbExclamation + vbOKOnly, "Access denied"
EDBoxlogin.Value = "" And EDBoxpass.Value = ""
' I want to delete previous text in the editbox fields
count = count - 1
GoTo MM
Else
ThisWorkbook.Close
End If
End If
End If
End Sub
If you don't really need to know which user is opening the workbook, consider using Excel's built-in password security function. Also, you should encrypt the contents of the file also using Excel's built-in functions, or anyone can open the file with a text editor and find the userID and password listed in your code.
If you must use a login form, and I've also had to do so in the past, the following code builds on what you did by adding a user list to a hidden worksheet Users. Column A in that sheet needs to be the user names, B contains the passwords. This worksheet also uses cell D1 to track failed login attempts. Using variables in code for this sort of thing is tough ... you have to make them Public and if there are any errors when running code, it will lose its value, then bad things can happen.
The code also references another sheet, SplashPage. This allows you to hide Project1 when the user exits the workbook. The code I wrote handles the hide/unhide process when the file is opened or closed.
I don't know a way to turn off the close box in a user form. I've added code to reject the login if a user does that.
Happy coding.
'Module: frmLogin
Private Sub BtOK_Click()
Dim User1 As String
Dim Passwd As Variant
Sheets("Users").Range("D2").Value = False
User1 = EDBoxlogin.Value
Passwd = getPassword(User1)
If User1 <> "" And Passwd <> "" And EDBoxpass.Value = Passwd Then
Sheets("Users").Range("D2").Value = True
MsgBox "Welcome " & User1 & "!", vbExclamation, "Access Granted"
With Sheets("Plan1")
.Visible = xlSheetVisible
.Activate
End With
Sheets("SplashPage").Visible = xlSheetVeryHidden
Unload Me
Exit Sub
Else
Sheets("Users").Range("D1").Value = Sheets("Users").Range("D1").Value - 1
If Sheets("Users").Range("D1").Value > 0 Then
MsgBox "Login and pass are incorrect! You have " & Sheets("Users").Range("D1").Value & _
" more trial(s)", vbExclamation + vbOKOnly, "Access denied"
EDBoxpass.Value = ""
With EDBoxlogin
.Value = ""
.SetFocus
End With
' I want to delete previous text in the editbox fields
Exit Sub
End If
End If
UserForm_Terminate
End Sub
Private Sub UserForm_Terminate()
If Sheets("Users").Range("D2").Value <> True Then
MsgBox "Login cancelled, goodbye!"
doWorkbookClose
End If
End Sub
'Module: ThisWorkbook
Private Sub Workbook_BeforeClose(Cancel As Boolean)
doWorkbookClose
End Sub
Private Sub Workbook_Open()
On Error Resume Next
Sheets("Users").Range("D1").Value = 3
With Sheets("SplashPage")
.Visible = xlSheetVisible
.Activate
End With
Sheets("Plan1").Visible = xlSheetVeryHidden
Sheets("Users").Visible = xlSheetVeryHidden
ThisWorkbook.Save
frmLogin.Show
End Sub
'Module: Module1
Function getPassword(strVarib As String) As Variant
Dim r As Long
Dim sht As Worksheet
Dim rng As Range
On Error GoTo ErrorHandler
Set sht = Sheets("Users")
Set rng = sht.Range("A:A")
r = WorksheetFunction.Match(strVarib, rng, 0)
getPassword = sht.Cells(r, 2).Value
Exit Function
ErrorHandler:
getPassword = Empty
End Function
Sub doWorkbookClose()
On Error Resume Next
With Sheets("SplashPage")
.Visible = xlSheetVisible
.Activate
End With
Sheets("Plan1").Visible = xlSheetVeryHidden
Sheets("Users").Visible = xlSheetVeryHidden
ThisWorkbook.Save
End Sub
[begin Q&A]
Luiz, I've answered your edits below.
'Q: What Passwd does?
'Module: frmLogin
....
Passwd = getPassword(User1)
A: It gets the password value matching the value of User1. Here's the whole function for context:
Function getPassword(strVarib As String) As Variant
Dim r As Long
Dim sht As Worksheet
Dim rng As Range
On Error GoTo ErrorHandler
Set sht = Sheets("Users")
Set rng = sht.Range("A:A")
r = WorksheetFunction.Match(strVarib, rng, 0)
getPassword = sht.Cells(r, 2).Value
Exit Function
ErrorHandler:
getPassword = Empty
If User1 does not exist then WorksheetFunction.Match throws an error and code execution will jump to ErrorHandler:.
'Q: Does Empty mean that the cell is not with zeros or spaces, but completely blank instead?
A: Empty refers to a Variant variable type that is set to its default value. getPassword could just as easily return the boolean False or integer 0 because those are the default values for those types. It's actually not strictly necessary to set getPassword to anything here ... it's just my personal practice to be explicit.
Since IsEmpty(celFoo) is a valid test for whether a cell is empty or not, you might want to return False instead of Empty to avoid ambiguity.
'Q: Can you explain these two lines below in detail?
Set sht = Sheets("Users")
Set rng = sht.Range("A:A")
A: It's just habit. The alternative would be to elminate those variable assignments and rewrite this line:
r = WorksheetFunction.Match(strVarib, rng, 0)
as:
r = WorksheetFunction.Match(strVarib, Sheets("Users").Range("A:A"), 0)
which is messier to type. Especially if we're going to be doing other things on that sheet with that range in the same routine. Which we are in the next block of code ...
'Q: Important to explain these three lines below in detail too [why 0?, To where (r,2) points to?]
r = WorksheetFunction.Match(strVarib, rng, 0)
getPassword = sht.Cells(r, 2).Value
Exit Function
A: To review, worksheet Users contains user IDs in column A, and their passwords in column B. There can be as many users as there are rows in a worksheet.
- rng is column A as set above.
- 0 means find an exact match for strVarib and throw an error if not match is found.
- If we find a match, r will be set to the row number where the value in column A is equal to our input parameter, strVarib.
- So, sht.Cells(r, 2).Value is the password value in column B (column 2) for the UserID.
'Q: Why the need to call a splashpage? What it contains?
A: You don't necessarily need one, but if you really want to secure your workbook it's good practice. Let's say that it contains sensitive information that you don't want unauthorized user to see. At the very least you would:
Encrypt the worbook using native Excel functionality.
Password protect your VBA project using native functionality. This keeps savvier users from reading your code and making the xlSheetVeryHidden sheets Users and Plan1 visible to their prying eyes.
Now, you can't hide all sheets in a workbook at the same time, at least one needs to be visible at any given time ...
... so I've created a third sheet called SplashPage that doesn't contain any sensitive information. And that means I can hide all of the other worksheets until the user enters a valid UserID and password in frmLogin.
SplashPage can contain whatever you want. You can call it whatever you want. Typically, mine says something like:
Welcome to the Enemies List Application!
Only authorized users may access this workbook.
If you're seeing this page and no login form is visible
it means you've disabled the macros in this workbook.
Please make sure macro security is set to "Medium"
then close Excel entirely, reopen this file
and select "Enable Macros" when prompted.
If you attempt to view or modify this file without proper
authorization you will be added to the list herein.
-[Signed] Richard M. Nixon
A really really secure workbook would not contain the users and passwords in a hidden sheet. In fact, I never do this. Most of my apps are database driven, and I authenticate users against both the domain and a custom table in the application database. This effectively keeps anyone from using it unless they're onsite and connected to the network. I also usually flush all the data from the relevant worksheets when the user closes the workbook to a) keep the file size smaller and b) keep sensitive data from being stored in it and taken offsite. But that's beyond the original scope of your question.
'Why is [the following] necessary? What is being saved? Purpose?
Private Sub Workbook_BeforeClose(Cancel As Boolean)
ThisWorkbook.Save
A: There are two scenarios for closing the application: 1) a failed login attempt and 2) a successful login by a user who has finished making changes.
Take case (2) first. We want to hide all the sensitive information before closing so that the next person who opens the file only sees SplashPage and the login form. We know the user is closing the workbook because we have this code in the ThisWorkbook module BeforeClose event script:
'Module: ThisWorkbook
Private Sub Workbook_BeforeClose(Cancel As Boolean)
doWorkbookClose
End Sub
All it does is call this subroutine in Module1:
Sub doWorkbookClose()
On Error Resume Next
With Sheets("SplashPage")
.Visible = xlSheetVisible
.Activate
End With
Sheets("Plan1").Visible = xlSheetVeryHidden
Sheets("Users").Visible = xlSheetVeryHidden
ThisWorkbook.Save
End Sub
Since our close routine makes changes to the workbook to hide sensitive information, those changes need to be saved. If ThisWorkbook.Save wasn't there, Excel would prompt the user if they wanted to save "their" changes. Which is annoying at best, confusing at worst, because most users will have already pressed "Save" before closing. And if we give them the option here now to close without saving, then we run the risk of all those sensitive worksheets we've just made xlVeryHidden visible to the next user. And that next user could be a bad guy who knows how to disable macros (or anyuser who simply has macro security set above Medium) which means that the following code wouldn't run:
Private Sub Workbook_Open()
On Error Resume Next
Sheets("Users").Range("D1").Value = 3
With Sheets("SplashPage")
.Visible = xlSheetVisible
.Activate
End With
Sheets("Plan1").Visible = xlSheetVeryHidden
Sheets("Users").Visible = xlSheetVeryHidden
ThisWorkbook.Save
frmLogin.Show
End Sub
which is my semi-paranoid-self trying to make it as sure as possible that the next user opening this file doesn't see something I don't want them to.
Note that none of this secuity is bomb-proof. It will lock out most average Excel users that you don't want in it, but someone who knows more about VBA than I do could probably find a way in.
Yes, that was an invitation. :)

Resources