Protection > Tough one

[MarkAndrews]

For me anyway

Is there a way I can include an message box into my Workbook_open event which would ask the user if they want to unprotect the sheet?

Yes/No

If Yes, then display a box for them to type the password which will unprotect specified sheets

On workbook_beforeclose, do the opposite of above?

I am stumped

TIA

 

[njimack]

I have the following in my personal.xls

Note: the 2nd portion of code creates an input box which masks the input using asterix's

Sub Protect_This_Sheet()
Dim myPassword As String
   
    myPassword = InputBoxDK("Please enter your password" & vbCrLf & _
                          "(Make sure you don't forget it)", "Enter Password")
    If myPassword = "" Then
        If MsgBox("You have not entered a password, do you want to proceed?     " & vbCrLf & _
                  "(Passwords are not necessary for minimal protection)", vbQuestion + vbYesNo, _
                  "Protect All Sheets") = vbNo Then Exit Sub
    End If

ActiveSheet.Protect (myPassword)
End Sub

Option Explicit
'////////////////////////////////////////////////////////////////////
'Password masked inputbox
'Allows you to hide characters entered in a VBA Inputbox.
'
'Code written by Daniel Klann
'March 2003
'////////////////////////////////////////////////////////////////////


'API functions to be used
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, _
ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long

Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long

Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" _
(ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, _
ByVal dwThreadId As Long) As Long

Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long

Private Declare Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" _
(ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal wMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long

Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, _
ByVal lpClassName As String, _
ByVal nMaxCount As Long) As Long

Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long

'Constants to be used in our API functions
Private Const EM_SETPASSWORDCHAR = &HCC
Private Const WH_CBT = 5
Private Const HCBT_ACTIVATE = 5
Private Const HC_ACTION = 0

Private hHook As Long

Public Function NewProc(ByVal lngCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim RetVal
Dim strClassName As String, lngBuffer As Long

If lngCode < HC_ACTION Then
NewProc = CallNextHookEx(hHook, lngCode, wParam, lParam)
Exit Function
End If

strClassName = String$(256, " ")
lngBuffer = 255

If lngCode = HCBT_ACTIVATE Then 'A window has been activated

RetVal = GetClassName(wParam, strClassName, lngBuffer)

If Left$(strClassName, RetVal) = "#32770" Then 'Class name of the Inputbox

'This changes the edit control so that it display the password character *.
'You can change the Asc("*") as you please.
SendDlgItemMessage wParam, &H1324, EM_SETPASSWORDCHAR, Asc("*"), &H0
End If

End If

'This line will ensure that any other hooks that may be in place are
'called correctly.
CallNextHookEx hHook, lngCode, wParam, lParam

End Function

Public Function InputBoxDK(Prompt, Optional Title, Optional Default, Optional XPos, _
Optional YPos, Optional HelpFile, Optional Context) As String
Dim lngModHwnd As Long, lngThreadID As Long

lngThreadID = GetCurrentThreadId
lngModHwnd = GetModuleHandle(vbNullString)

hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID)

InputBoxDK = InputBox(Prompt, Title, Default, XPos, YPos, HelpFile, Context)
UnhookWindowsHookEx hHook

End Function

 

[MarkAndrews]

Neil thanks for this - It doesn't like this line when using F8 through the code

myPassword = InputBoxDK("Please enter your password" & vbCrLf & _

Specifically InputBoxDK

???

Can i use this on multiple sheets?

 

[lozzablake]

You need to use the workbook open event and workbook beforeclose event. Something like these which need to go into the module for the workbook. You should password protect the code otherwise anyone can open the VBE and read the password in the code:

Private Sub Workbook_Open()
    Dim varAnswer
    Dim blnOK As Boolean
    Dim ws As Worksheet
    
        
    'keep looping until input is OK
    blnOK = False
    
    Do
        'get user input
        varAnswer = MsgBox("Do you wish to unprotect the sheets?", vbYesNo)
                
        'check for allowed entry
        If varAnswer = vbYes Then
            'check for password
            varAnswer = InputBox("please input the password")
            If varAnswer = "password" Then   'change for your password
                blnOK = True
                For Each ws In ThisWorkbook.Sheets  'change for specific sheets as required
                    'may need password as argument in unprotect method
                    ws.Unprotect (varAnswer)
                Next ws
            Else
                MsgBox "Incorrect password - returning to Starting menu"
            
            End If
        Else
            blnOK = True
        End If
    
    Loop Until blnOK
        
End Sub

and

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Dim varAnswer
    Dim blnOK As Boolean
    Dim ws As Worksheet
    
        
    'keep looping until input is OK
    blnOK = False
    
    Do
        'get user input
        varAnswer = MsgBox("Do you wish to protect the sheets?", vbYesNo)
                
        'check for allowed entry
        If varAnswer = vbYes Then
            'check for password
            varAnswer = InputBox("please input the password")
            If varAnswer = "password" Then   'change for your password
                blnOK = True
                For Each ws In ThisWorkbook.Sheets  'change for specific sheets as required
                    'may need password as argument in unprotect method
                    ws.Protect (varAnswer)
                Next ws
            Else
                MsgBox "Incorrect password - returning to Starting menu"
            
            End If
        Else
            blnOK = True
        End If
    
    Loop Until blnOK
        
End Sub

 

[MarkAndrews]

Fantastic, thanks