If User Selects Cancel All Sheets are Unprotected

C

christianbiker

Active Member
Joined
Feb 3, 2006
Messages
379
Hi all,

I am using the below code when I user would like to change the password for all worksheets in a workbook. Once they enter their current password, all worksheets in the workbook are unprotected with the current password and a second popup appears asking for the new password followed by a third popup that asks for confirmation of the password. If the user clicks "Cancel" or selects the "X" on both new password boxes, the popups close and all worksheets are left unprotected completely. How do I prevent this from happening?

Thanks in advance.

VBA Code: 
MSG1 = MsgBox("***WARNING***" & vbNewLine & vbNewLine & _
"YOU HAVE INITIATED THE PROCESS OF CHANGING THE PASSWORD FOR THE ENTIRE SCHEDULE. DO YOU WISH TO CONTINUE?" & vbNewLine & vbNewLine & _
"Click ""Yes"" to continue, ""No"" to cancel.", vbYesNo, "UNLOCK LIVE SCHEDULE")

If MSG1 = vbYes Then
    On Error GoTo booboo
        unpass = InputBox("Enter the current password.")
        For Each Worksheet In ActiveWorkbook.Worksheets
        Worksheet.Unprotect Password:=unpass
        Next
        GoTo 2
    Exit Sub
Else
    Exit Sub
End If

Application.ScreenUpdating = False

2:
    Dim pwd1 As String, pwd2 As String
    pwd1 = InputBox("Please enter the new password.")
    If pwd1 = "" Then Exit Sub
    pwd2 = InputBox("Re-enter the password." & vbNewLine & vbNewLine & "***ALERT*** PLEASE ENSURE YOU STORE THE NEW PASSWORD IN A SAFE LOCATION." & vbNewLine & vbNewLine & _
    "THIS CANNOT BE UNDONE ONCE ""OK"" IS SELECTED.")

    If pwd2 = "" Then Exit Sub

     'Check if both the passwords are identical
    If InStr(1, pwd2, pwd1, 0) = 0 Or _
    InStr(1, pwd1, pwd2, 0) = 0 Then
        MsgBox "You entered different passwords. No action taken"
        Exit Sub
    End If

    For Each ws In Worksheets
        ws.Protect Password:=pwd1, DrawingObjects:=False, Contents:=True, Scenarios:=True, AllowFormattingCells:=True
        
    Next

    MsgBox "Your password has been changed and all sheets have been protected."
    Worksheets("HOME PAGE").Activate

    Exit Sub
Application.ScreenUpdating = True

booboo: MsgBox "You have either cancelled the password change process or there is a problem with your password. Click ""Ok"" to continue."
Exit Sub
 

Excel Facts

Can you sort left to right?
To sort left-to-right, use the Sort dialog box. Click Options. Choose "Sort left to right"
Sort by date Sort by votes
try
VBA Code: 
Sub cbiker()
MSG1 = MsgBox("***WARNING***" & vbNewLine & vbNewLine & _
"YOU HAVE INITIATED THE PROCESS OF CHANGING THE PASSWORD FOR THE ENTIRE SCHEDULE. DO YOU WISH TO CONTINUE?" & vbNewLine & vbNewLine & _
"Click ""Yes"" to continue, ""No"" to cancel.", vbYesNo, "UNLOCK LIVE SCHEDULE")

If MSG1 = vbYes Then
    On Error GoTo booboo
        unpass = InputBox("Enter the current password.")
        For Each Worksheet In ActiveWorkbook.Worksheets
        Worksheet.Unprotect Password:=unpass
        Next
        GoTo 2
    Exit Sub
Else
    Exit Sub
End If

Application.ScreenUpdating = False

2:
    Dim pwd1 As String, pwd2 As String
    pwd1 = InputBox("Please enter the new password.")
    If pwd1 = "" Then GoTo lockme
    pwd2 = InputBox("Re-enter the password." & vbNewLine & vbNewLine & "***ALERT*** PLEASE ENSURE YOU STORE THE NEW PASSWORD IN A SAFE LOCATION." & vbNewLine & vbNewLine & _
    "THIS CANNOT BE UNDONE ONCE ""OK"" IS SELECTED.")

    If pwd2 = "" Then GoTo lockme

     'Check if both the passwords are identical
    If InStr(1, pwd2, pwd1, 0) = 0 Or _
    InStr(1, pwd1, pwd2, 0) = 0 Then
        MsgBox "You entered different passwords. No action taken"
        Exit Sub
    End If

    For Each ws In Worksheets
        ws.Protect Password:=pwd1, DrawingObjects:=False, Contents:=True, Scenarios:=True, AllowFormattingCells:=True
       
    Next

    MsgBox "Your password has been changed and all sheets have been protected."
    Worksheets("HOME PAGE").Activate
    Application.ScreenUpdating = True

    Exit Sub

lockme:
For Each Worksheet In ActiveWorkbook.Worksheets
        Worksheet.Protect Password:=unpass
        Next
booboo: MsgBox "You have either cancelled the password change process or there is a problem with your password. Click ""Ok"" to continue."
'

End Sub
 
Upvote 0
Could you try it and share the result?

VBA Code: 
Sub ChangeWorksheetPassword()

    Dim MSG1 As Integer
    Dim unpass As String
    Dim pwd1 As String
    Dim pwd2 As String
    Dim ws As Worksheet

    MSG1 = MsgBox("***WARNING***" & vbNewLine & vbNewLine & _
    "YOU HAVE INITIATED THE PROCESS OF CHANGING THE PASSWORD FOR THE ENTIRE SCHEDULE. DO YOU WISH TO CONTINUE?" & vbNewLine & vbNewLine & _
    "Click ""Yes"" to continue, ""No"" to cancel.", vbYesNo, "UNLOCK LIVE SCHEDULE")

    If MSG1 = vbYes Then
    
        unpass = InputBox("Enter the current password.")
        If unpass = "" Then
            MsgBox "You have cancelled the operation."
            Exit Sub
        End If

        pwd1 = InputBox("Please enter the new password.")
        If pwd1 = "" Then
            MsgBox "You have cancelled the operation."
            Exit Sub
        End If

        pwd2 = InputBox("Re-enter the password." & vbNewLine & vbNewLine & _
        "***ALERT*** PLEASE ENSURE YOU STORE THE NEW PASSWORD IN A SAFE LOCATION." & vbNewLine & vbNewLine & _
        "THIS CANNOT BE UNDONE ONCE ""OK"" IS SELECTED.")

        If pwd2 = "" Then
            MsgBox "You have cancelled the operation."
            Exit Sub
        End If

        If pwd1 <> pwd2 Then
            MsgBox "You entered different passwords. No action taken."
            Exit Sub
        End If

        Application.ScreenUpdating = False

        On Error GoTo booboo

        For Each ws In Worksheets
            ws.Unprotect Password:=unpass
            ws.Protect Password:=pwd1, DrawingObjects:=False, Contents:=True, Scenarios:=True, AllowFormattingCells:=True
        Next

        Application.ScreenUpdating = True

        MsgBox "Your password has been changed and all sheets have been protected."
        Worksheets("HOME PAGE").Activate

    Else
        Exit Sub
    End If

    Exit Sub

booboo:
    MsgBox "There was a problem changing the password. The current password may be incorrect, or an error occurred."
    Application.ScreenUpdating = True
    For Each ws In Worksheets
        On Error Resume Next
        ws.Protect Password:=unpass, DrawingObjects:=False, Contents:=True, Scenarios:=True, AllowFormattingCells:=True
    Next
    Exit Sub

End Sub
 
Upvote 0
Hi
it would be a little simpler to create a userform where you can also mask the password but as an excercise using inputbox - see if following does what you want

VBA Code: 
Sub ChangePassword()
    Dim Passwords(1 To 3)   As Variant
    Dim ValidEntry          As Boolean
    Dim strPrompt           As String, strTitle As String
    Dim ws                  As Worksheet
    Dim msg1                As VbMsgBoxResult
    Dim NextStep            As Long
    
    Const CurrentPassword As Long = 1, NewPassword As Long = 2, NewPasswordAgain As Long = 3
    
    Const strAlert  As String = vbNewLine & vbNewLine & _
          "***ALERT*** PLEASE ENSURE YOU STORE THE New PASSWORD IN A SAFE LOCATION." & vbNewLine & _
          "THIS CANNOT BE UNDONE ONCE ""OK"" Is SELECTED."
    
    '---------------------------------------------------------------------------------------
    '                                       SETTINGS
    '---------------------------------------------------------------------------------------
    'set min password lenght
    Const MinPasswordLen As Long = 8
    '--------------------------------------------------------------------------------------
    
    msg1 = MsgBox("***WARNING***" & vbNewLine & vbNewLine & _
           "YOU HAVE INITIATED THE PROCESS OF CHANGING THE PASSWORD For THE ENTIRE SCHEDULE. Do YOU WISH To CONTINUE?" & vbNewLine & vbNewLine & _
           "Click ""Yes"" To continue, ""No"" To cancel.", 292, "UNLOCK LIVE SCHEDULE")
    If msg1 = vbNo Then Exit Sub
    
starthere:
    NextStep = 1
    Do
        strPrompt = Choose(NextStep, "Current Password", "New Password", "New Password Again")
        strPrompt = IIf(NextStep = 3, strPrompt & strAlert, strPrompt)
        
        strTitle = IIf(NextStep < 3, strPrompt, strTitle)
        
        Passwords(NextStep) = InputBox("Please Enter " & strPrompt, strTitle)
        'cancel pressed
        If StrPtr(Passwords(NextStep)) = 0 Then Exit Sub
        
        If NextStep = 1 Then
            
            ValidEntry = Passwords(CurrentPassword) <> ""
            If Not ValidEntry Then MsgBox "Current Password Must Be Entered", 48, "Password"
            
        ElseIf NextStep = 2 Then
            
            ValidEntry = Passwords(NewPassword) <> Passwords(CurrentPassword)
            If Not ValidEntry Then MsgBox "You Cannot Reuse Current Password", 48, "Not Allowed"
            
            If ValidEntry Then
                ValidEntry = Len(Passwords(NewPassword)) >= MinPasswordLen
                If Not ValidEntry Then MsgBox "A Password Must Be Contain At Least " & MinPasswordLen & " Characters", 48, "Invalid Password"
            End If
            
        ElseIf NextStep = 3 Then
            
            ValidEntry = Passwords(NewPassword) = Passwords(NewPasswordAgain)
            If Not ValidEntry Then MsgBox "Passwords Do Not Match - Please try again", 48, "Passwords Do Not Match": NextStep = 2
        End If
        
        If ValidEntry Then NextStep = NextStep + 1
        
    Loop Until NextStep > 3
    
    On Error GoTo myerror
    For Each ws In ThisWorkbook.Worksheets
        ws.Unprotect Passwords(CurrentPassword)
        ws.Protect Password:=Passwords(NewPassword), DrawingObjects:=False, Contents:=True, Scenarios:=True, AllowFormattingCells:=True
    Next
    
    MsgBox "Your password has been changed And all sheets have been protected.", 64, "Success"
    Worksheets("HOME PAGE").Activate
    
myerror:
    If Err <> 0 Then
        MsgBox (Error(Err)), 48, "Error"
        Resume starthere
    End If
End Sub

I also added some additional tests (password length & re-use same password) which may find helpful

Dave

Dave
 
Upvote 0
pitchoute said:
Could you try it and share the result?

VBA Code: 
Sub ChangeWorksheetPassword()

    Dim MSG1 As Integer
    Dim unpass As String
    Dim pwd1 As String
    Dim pwd2 As String
    Dim ws As Worksheet

    MSG1 = MsgBox("***WARNING***" & vbNewLine & vbNewLine & _
    "YOU HAVE INITIATED THE PROCESS OF CHANGING THE PASSWORD FOR THE ENTIRE SCHEDULE. DO YOU WISH TO CONTINUE?" & vbNewLine & vbNewLine & _
    "Click ""Yes"" to continue, ""No"" to cancel.", vbYesNo, "UNLOCK LIVE SCHEDULE")

    If MSG1 = vbYes Then
   
        unpass = InputBox("Enter the current password.")
        If unpass = "" Then
            MsgBox "You have cancelled the operation."
            Exit Sub
        End If

        pwd1 = InputBox("Please enter the new password.")
        If pwd1 = "" Then
            MsgBox "You have cancelled the operation."
            Exit Sub
        End If

        pwd2 = InputBox("Re-enter the password." & vbNewLine & vbNewLine & _
        "***ALERT*** PLEASE ENSURE YOU STORE THE NEW PASSWORD IN A SAFE LOCATION." & vbNewLine & vbNewLine & _
        "THIS CANNOT BE UNDONE ONCE ""OK"" IS SELECTED.")

        If pwd2 = "" Then
            MsgBox "You have cancelled the operation."
            Exit Sub
        End If

        If pwd1 <> pwd2 Then
            MsgBox "You entered different passwords. No action taken."
            Exit Sub
        End If

        Application.ScreenUpdating = False

        On Error GoTo booboo

        For Each ws In Worksheets
            ws.Unprotect Password:=unpass
            ws.Protect Password:=pwd1, DrawingObjects:=False, Contents:=True, Scenarios:=True, AllowFormattingCells:=True
        Next

        Application.ScreenUpdating = True

        MsgBox "Your password has been changed and all sheets have been protected."
        Worksheets("HOME PAGE").Activate

    Else
        Exit Sub
    End If

    Exit Sub

booboo:
    MsgBox "There was a problem changing the password. The current password may be incorrect, or an error occurred."
    Application.ScreenUpdating = True
    For Each ws In Worksheets
        On Error Resume Next
        ws.Protect Password:=unpass, DrawingObjects:=False, Contents:=True, Scenarios:=True, AllowFormattingCells:=True
    Next
    Exit Sub

End Sub
Click to expand...

Works like a charm! Thank you so much for your assistance!!!
 
Upvote 0
You must log in or register to reply here.

Similar threads

SaraWitch
  • Question Question
Unprotect/protect all worksheets with a checkbox
Replies
3
Views
997
skillilea
S
J
  • Question Question
Assistance changing VBA code to display as HTML or picture of a selection in Lotus Notes
Replies
2
Views
192
jularobert
J
M
  • Question Question
Using VBA code in a protected excel sheet
Replies
2
Views
407
MagicCarpet
M
C
  • Question Question
Force user to enter at least one symbol and one number in a textbox through a userform
Replies
9
Views
293
christianbiker
C
SaraWitch
  • Question Question
Protect all sheets except one
Replies
4
Views
938
dmt32
D

Forum statistics

Threads
1,222,622
Messages
6,167,104
Members
452,094
Latest member
Roberto Saveru

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top