Popup box asking for password to unprotect cell

[wackyracer8]

Hi, I have a excel sheet that is used to calculate staff hours and the sheet is protected with a password to stop people changing it. It has checkboxes and fields which add up/minus etc depending on what is chosen, something that has taken awhile to produce and something I am proud of.

I've got stuck and need some help. What I'd like to do is create a button that says Unlock for example, and when clicked a popup box appears asking for the password. When this is done the text changes to lock and when clicked the sheet is locked again and the wording changes to unlock.

If that is not achievable then I'm happy to have 2 buttons, unlock and lock which work as above.

Any ideas guys?

 

[MoshiM]

Hi, I have a excel sheet that is used to calculate staff hours and the sheet is protected with a password to stop people changing it. It has checkboxes and fields which add up/minus etc depending on what is chosen, something that has taken awhile to produce and something I am proud of.

I've got stuck and need some help. What I'd like to do is create a button that says Unlock for example, and when clicked a popup box appears asking for the password. When this is done the text changes to lock and when clicked the sheet is locked again and the wording changes to unlock.

If that is not achievable then I'm happy to have 2 buttons, unlock and lock which work as above.

Any ideas guys?

This is similar to what you want. Edit it so that the password is supplied with an "Application.inputbox" instead of a text file and adjust the stuff within the if statements to do what you want.

Private Function Worksheet_Protection_Toggle(Optional This_Sheet As Worksheet)

Dim Sheet_Pass As String, filenumber As Long, Path As String, MData As String, D_Str() As String

On Error GoTo 0

    If Environ("USERDOMAIN") = "CAMIL-PC" Then
    
        If This_Sheet Is Nothing Then Set This_Sheet = HUB
    
        If ThisWorkbook.Last_Used_Sheet Is Nothing And This_Sheet Is HUB Then HUB.Range("A4").Select
                
        On Error GoTo No_File_FOUND
            
        If ThisWorkbook.Password_M = "" Then 'password is stored in a text file
            
            Path = Environ("ONEDRIVE") & "\C-Password.txt"
            
            filenumber = FreeFile
            
            Open Path For Input As [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=filenumber]#filenumber[/URL] 
            
            MData = Input(LOF(filenumber), [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=filenumber]#filenumber[/URL] )
            
            D_Str = Split(MData, Chr(44))'file is delimted with a comma
            
            ThisWorkbook.Password_M = D_Str(0)
            
            Close [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=filenumber]#filenumber[/URL] 
                
        End If
        
        On Error GoTo Error_While_Locking
 
        With This_Sheet
  
            If .ProtectContents = True Then
            
                .Unprotect ThisWorkbook.Password_M
                
                If This_Sheet Is HUB Then
                    .Shapes("My_Date").Fill.ForeColor.RGB = RGB(51, 102, 0)
                    .Shapes("My_Date_ICE").Fill.ForeColor.RGB = RGB(51, 102, 0)
                End If
                
            Else 'IF it is not protected then protect the sheet
                    
                 If This_Sheet Is HUB Then
                    .Shapes("My_Date").Fill.ForeColor.RGB = RGB(0, 0, 0)
                    .Shapes("My_Date_ICE").Fill.ForeColor.RGB = RGB(0, 0, 0)
                End If
                
                .Protect ThisWorkbook.Password_M, True, True, True, False, True, True, True, False, False, True, False, False, True, True, True

            End If
        
        End With

    End If
    
Exit Function
Error_While_Locking:
    MsgBox This_Sheet.Name & " could not be locked"
    Exit Function

No_File_FOUND:
    MsgBox "Password File not found in OneDrive folder. Worksheets were not locked. If Password has been forgotten check DropBox or Onedrive."
End Function