I have added the following code to an excel doc that requires two levels of access. This part works great, but we've found that if the user clicks and holds down the left mouse button over a worksheet tab, they can view the document and are not presented with the password req until the mouse button is released.
I've tried various methods to get around this but my knowledge of vbscript with Excel just isn't what I'd like it to be. I've tried hiding the cells, hiding the worksheet until the password is entered correctly, and some other steps that didn't work out though I can't rule out that it isn't possible. I've considered forcing the cells to use a different format (;; or making them use a background color that is the same as the font and this would be a fine solution except it seems that it would be very difficult to implement since there are various colors of fonts and cell backgrounds that would somehow have to be recorded and replaced back to normal upon the correct password being entered.
This is just some of the background on what I've tried. Ultimately, I just want the user to not be able to see anything until a password is entered, even if they hold the mouse button down on the tab.
Here's the code:
I've tried various methods to get around this but my knowledge of vbscript with Excel just isn't what I'd like it to be. I've tried hiding the cells, hiding the worksheet until the password is entered correctly, and some other steps that didn't work out though I can't rule out that it isn't possible. I've considered forcing the cells to use a different format (;; or making them use a background color that is the same as the font and this would be a fine solution except it seems that it would be very difficult to implement since there are various colors of fonts and cell backgrounds that would somehow have to be recorded and replaced back to normal upon the correct password being entered.
This is just some of the background on what I've tried. Ultimately, I just want the user to not be able to see anything until a password is entered, even if they hold the mouse button down on the tab.
Here's the code:
Code:
Dim LockedSheets As Object
Dim LastActiveSheet As Worksheet
Dim S As Worksheet
Dim TempSheetVar As Worksheet
Dim UserInput As Variant
Const PWord1 As String = "pass1"
Const PWord2 As String = "pass2"
Const Msg1 As String = " is password protected" & vbNewLine _
& vbNewLine & "Please enter a valid password to enable viewing"
Const Msg2 As String = "Incorrect Password!"
Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
Application.ScreenUpdating = False
For Each S In LockedSheets
S.Visible = xlvryhidden
Next S
Me.Save 'This is to ensure hiding sheets is saved
End Sub
Private Sub Workbook_Open()
On Error Resume Next
Worksheets("HOME").Activate
Application.ScreenUpdating = False
' ADD SHEET NAMES USING THE PATTERN BELOW TO ADD PASSWORDS TO NEW SHEETS
Set LockedSheets = Worksheets(Array("BUDGET", "IMPORT", "COS", "PAYROLL", "RESIN", "STD", "ALLOC", "REV", "INDICATOR", "26FTV", "28FTV", "26SFV", "28SFV", "38ISC", "38ISS", "38ISO", "38ITC", "38IPP", "38TPD", "38TPC", "38ISU", "5GLIN", "38ITC F", "38ISO F"))
For Each S In LockedSheets
S.Visible = True
Next S
End Sub
Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
On Error Resume Next
Set TempSheetVar = LockedSheets(Sh.Name)
Set TempSheetVar = Nothing
If Err.Number = 9 Then ' if Sh out of range store it in a global var
Err.Clear
Application.ScreenUpdating = False
Set LastActiveSheet = Sh
End If
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
On Error Resume Next
Set TempSheetVar = LockedSheets(Sh.Name)
If Err.Number = 0 Then
With Application
.EnableEvents = False
Sh.Visible = False
LastActiveSheet.Activate
.EnableEvents = True
End With
PromptForPassword TempSheetVar
Set TempSheetVar = Nothing
End If
Err.Clear
End Sub
Sub PromptForPassword(LockedWorkSheet As Worksheet)
With Application
Do
UserInput = .InputBox("'" & LockedWorkSheet.Name & "'" & Msg1)
Select Case UserInput
Case Is = False ' if user cancels don't activate sheet
Exit Do
Case Is = PWord1 ' if password correct activate sheet
' ALL OF THE WORKSHEETS THAT ACCEPT PWord1 MUST BE LISTED BELOW
If LockedWorkSheet.Name = "BUDGET" Or LockedWorkSheet.Name = "IMPORT" Or LockedWorkSheet.Name = "COS" Or LockedWorkSheet.Name = "PAYROLL" Or LockedWorkSheet.Name = "RESIN" Or LockedWorkSheet.Name = "STD" Or LockedWorkSheet.Name = "ALLOC" Or LockedWorkSheet.Name = "REV" Or LockedWorkSheet.Name = "INDICATOR" Or LockedWorkSheet.Name = "26FTV" Or LockedWorkSheet.Name = "28FTV" Or LockedWorkSheet.Name = "26SFV" Or LockedWorkSheet.Name = "28SFV" Or LockedWorkSheet.Name = "38ISC" Or LockedWorkSheet.Name = "38ISS" Or LockedWorkSheet.Name = "38ISO" Or LockedWorkSheet.Name = "38ITC" Or LockedWorkSheet.Name = "38IPP" Or LockedWorkSheet.Name = "38TPD" Or LockedWorkSheet.Name = "38TPC" Or LockedWorkSheet.Name = "38ISU" Or LockedWorkSheet.Name = "5GLIN" Or LockedWorkSheet.Name = "38ITC F" Or LockedWorkSheet.Name = "38ISO F" Then
Set LastActiveSheet = LockedWorkSheet
Exit Do
End If
Case Is = PWord2 ' if password correct activate sheet
' ALL OF THE WORKSHEETS THAT ACCEPT PWord2 MUST BE LISTED BELOW
If LockedWorkSheet.Name = "26FTV" Or LockedWorkSheet.Name = "28FTV" Or LockedWorkSheet.Name = "26SFV" Or LockedWorkSheet.Name = "28SFV" Or LockedWorkSheet.Name = "38ISC" Or LockedWorkSheet.Name = "38ISS" Or LockedWorkSheet.Name = "38ISO" Or LockedWorkSheet.Name = "38ITC" Or LockedWorkSheet.Name = "38IPP" Or LockedWorkSheet.Name = "38TPD" Or LockedWorkSheet.Name = "38TPC" Or LockedWorkSheet.Name = "38ISU" Or LockedWorkSheet.Name = "5GLIN" Or LockedWorkSheet.Name = "38ITC F" Or LockedWorkSheet.Name = "38ISO F" Then
Set LastActiveSheet = LockedWorkSheet
Exit Do
End If
Case Else 'if wrong password give user another try
UserDecision = MsgBox(Msg2, vbRetryCancel): Beep
End Select
Loop Until UserDecision = vbCancel
LockedWorkSheet.Visible = True
.EnableEvents = False
LastActiveSheet.Activate
.EnableEvents = True
End With
End Sub