Prompt for Password when Protecting a sheet

[Justplainj]

Hi All.

I am using the following code to use a button to protect a sheet.

Sub ProtectSheetWithPassword()

Dim sh As Worksheet
Set sh = ActiveSheet

sh.Shapes("ProtectBtn").Visible = msoFalse
sh.Shapes("UnprotectBtn").Visible = msoTrue

'Protect worksheet with a password
ActiveSheet.Protect Password:=Range("A2")

    Range("A2").Select
    Selection.ClearContents

End Sub

I am currently opting for the user to type the password in cell A2 to accept the password.
The unprotect macro is similar but I do not specify a range so that excel automatically uses a pop up where they enter the password.

Question.
How can I edit the above code to use a popup to enter the password when the sheet is being 'Protected', like it does when you unprotect?

Thanks in advance.
JPJ

 

[Justplainj]

Hi,

Just for interest sake. This is the code i use to unprotect the sheet.
I use shaped buttons I created in PPT as a custom toggle button.
Trying to give as much info as possible

Just trying to figure out to use the password prompt box instead of the user typing in a cell to password lock the sheet.

Sub UnProtectSheetWithPassword()

Dim sh As Worksheet, pass As String
Set sh = ActiveSheet

sh.Shapes("ProtectBtn").Visible = msoTrue
sh.Shapes("UnprotectBtn").Visible = msoFalse

'Unprotect worksheet with a password
On Error GoTo Popup:
ActiveSheet.Unprotect


Range("A2").Select
Selection.ClearContents

Exit Sub
Popup:
If Err.Number = 1004 Then

sh.Shapes("ProtectBtn").Visible = msoFalse
sh.Shapes("UnprotectBtn").Visible = msoTrue

Range("A2").Select
Selection.ClearContents

MsgBox "Incorrect Password"

End If

 

[mikerickson]

You could get the password from an InputBox rather than the Protect dialog.

Dim uiPW as String

uiPW = Application.InputBox("Password please", type:=2)
If uiPW = "False" Then Exit Sub: Rem cancel pressed

ActiveSheet.Protect Password:=uiPW

There could be alterations to force the user to enter the password twice or to force a non "" password. (Was it Gosper or Goldblatt who advised MIT professors to all use "" as their password?)

 

[Justplainj]

Thank you mikerickson.
Works perfectly.

You did peak my interest though with.

There could be alterations to force the user to enter the password twice or to force a non "" password.

 

[Justplainj]

HI,

I came up with this in the end to force entering the password twice and not to have blank password

Sub ProtectSheetWithPassword()

Dim sh As Worksheet
Dim uiPW1 As String
Dim uiPW2 As String
Set sh = ActiveSheet

sh.Shapes("ProtectBtn").Visible = msoFalse
sh.Shapes("UnprotectBtn").Visible = msoTrue

'Protect worksheet with a password
uiPW1 = Application.InputBox("Please enter password", Type:=2)
uiPW2 = Application.InputBox("Please enter password again", Type:=2)

If uiPW1 = "" Then
    sh.Shapes("ProtectBtn").Visible = msoTrue
    sh.Shapes("UnprotectBtn").Visible = msoFalse
    MsgBox "Password cannot be blank"
Else
sh.Shapes("ProtectBtn").Visible = msoTrue
sh.Shapes("UnprotectBtn").Visible = msoFalse

    If uiPW1 = uiPW2 Then
        If uiPW1 = "False" Then Exit Sub: Rem cancel pressed
        ActiveSheet.Protect Password:=uiPW1, DrawingObjects:=True, Contents:=True, Scenarios:=True

        Range("A2").Select
        Selection.ClearContents
        Range("A1") = "Click Unprotect WS to edit sheet"

        MsgBox "The sheet is Protected and cannot be edited"
    Else

    MsgBox "Password does not match, Please retry"

    End If

End If
   
End Sub

 

[mikerickson]

For the two pass password entry

Dim uiPW1 as String, uiPW2 as String

Do
    uiPW1 = InputBox("Password please", type:=2)
    If uiPW1 = "False" Then Exit Sub
    uiPW2 = InputBox("Retype password", type:=2
    If uiPW2 = "False" Then Exit Sub
    If uiPW1 <> uiPW2 Then
        If MsgBox("Password mismatch. Try again.", vbOKCancel) = vbCancel Then Exit Sub
    End If
Loop until uiPW1=uiPW2
ActiveSheet.Protect Password:=uiPW1

 

[Justplainj]

Thanks. Yours is so much cleaner