Locking a Workbook on a particular date

EE Professionals,

I'm looking for a very simple piece of code that checks a <NOW> statement on a cell on a worksheet and if the current date/time has been exceeded, it locks THE ENTIRE WORKBOOK with a particular password that is built into the macro (can be modified).  Putting the new password in restores access.

That's it!

Thank you in advance,

B.
Bright01Asked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

McOzCommented:
Put this in your workbook_open event:
If Date >= DateValue("3/29/2011") Then
    ActiveSheet.Protect Password:="password", DrawingObjects:=True, Contents:=True, Scenarios:=True
    ActiveWorkbook.Protect Password:="password", Structure:=True, Windows:=False
End If

Open in new window

0
Eric ZwiekhorstSAP Business ConsultantCommented:
Dear Bright, change the code to this
now your file will be saved with the password active and closed so if you try to open it again it will ask for this password. It will do this only if the workbook is not protected..

Private Sub Workbook_Open()
Application.DisplayAlerts = False
If Date >= DateValue("3/28/2011") And ActiveSheet.Protect = True Then
    ActiveSheet.Protect Password:="password", DrawingObjects:=True, Contents:=True, Scenarios:=True
    ActiveWorkbook.Protect Password:="password", Structure:=True, Windows:=False
    ActiveWorkbook.SaveAs Me.Name, , "Password"
    Me.Close
End If
Application.DisplayAlerts = True
End Sub
0
Eric ZwiekhorstSAP Business ConsultantCommented:
sorry that did not work

try this

Private Sub Workbook_Open()
Dim t As Variant
Application.DisplayAlerts = False
t = ActiveWorkbook.Password
If Date >= DateValue("3/28/2011") And t = "" Then
    ActiveSheet.Protect Password:="password", DrawingObjects:=True, Contents:=True, Scenarios:=True
    ActiveWorkbook.Protect Password:="password", Structure:=True, Windows:=False
    ActiveWorkbook.SaveAs Me.Name, , "password"
    Me.Close
End If
Application.DisplayAlerts = True
End Sub
0
PMI ACP® Project Management

Prepare for the PMI Agile Certified Practitioner (PMI-ACP)® exam, which formally recognizes your knowledge of agile principles and your skill with agile techniques.

McOzCommented:
Zwiekhorst has a good point, because without  saving the protected workbook anyone could simply bypass th automatic locking by holding down SHIFT while the workbook is opening.

A note on your question above:
"I'm looking for a very simple piece of code that checks a <NOW> statement on a cell on a worksheet and if the current date/time has been exceeded..."

I'm not sure what you mean by current date being exceeded, as NOW() of course will always return the current date. (There is also no need to reference a cell to get the date as this can be accessed directly from VBA as in the example provided.)
If you want to compare the current date with the static date contained in a cell to determine whether to lock the workbook, use this code:
Private Sub Workbook_Open()
Dim p as String, dtRng as Range
Application.DisplayAlerts = False
p = "password" 'password to assign
dtRng = Sheets("Sheet1").Range("A1") 'cell containing date
If Date >= DateValue(dtRng.value) And ActiveWorkbook.Password = "" Then
    ActiveSheet.Protect Password:=p, DrawingObjects:=True, Contents:=True, Scenarios:=True
    ActiveWorkbook.Protect Password:=p, Structure:=True, Windows:=False
    ActiveWorkbook.SaveAs(Me.Name, , p)
    Me.Close
End If
Application.DisplayAlerts = True
End Sub

Open in new window


Cheers
0
Bright01Author Commented:
ok.....several quick questions.  If I read you guys right, the code above checks the current date in cell A1, and a date that is in cell A1 is less than the current system date, it password protects the spreadsheet once it is closed at that time.   Is that right?  Can you add some comments into the code so I can understand how to control the macro (and integrate it)?  My workbook is not locked but I do have several worksheets that are protected and the project is protected.....is that a problem?

Thank you,

Jim  
0
Eric ZwiekhorstSAP Business ConsultantCommented:
Dear Bright,

I noticed that you can't check if the password has been filled, it always show ***** in VBA.

you can check however if the sheet is protected so the code should be this

Private Sub Workbook_Open()
Dim t As Variant
Application.DisplayAlerts = False 'not show the are you sure message when saving with password
If Date >= DateValue(range("A1")) And ActiveSheet.ProtectContents = False Then 'check date and if sheet was already protected
    ActiveSheet.Protect Password:="password", DrawingObjects:=True, Contents:=True, Scenarios:=True
    ActiveWorkbook.Protect Password:="password", Structure:=True, Windows:=False
    ActiveWorkbook.SaveAs Me.Name, , "password" 'save file with password
    Me.Close 'close file after save to prevent user to make a save without password
End If
Application.DisplayAlerts = True
End Sub
0
Bright01Author Commented:
Zwiekhorst,

Thanks for the note. Do I put this code in the initial splash screen worksheet, a module or This Workbook?

Thanks,

B.
0
McOzCommented:
The code needs to go in "This Workbook".

Cheers
0
Bright01Author Commented:
McOz and Zwiekhorst,

Let me make sure I understand;

1.) I put the code in This Workbook (may I have two "Open" macros in this file or do I need to consolidate them)?
2.) I have multiple worksheets. I believe that the code looks to cell A1 but in what worksheet?
3.) I change to the password I want by replacing "password" in the code?

Thank you,

B.
0
McOzCommented:
1) In the "ThisWorkbook" module, you can only have one Workbook_open macro, so you will need to consolidate.
2) Yes - The code will need to specify which sheet the cell is in.
3) Yes

I propose the following code to combine the functionality we have been talking about - Zwiekhorst, does this look OK?

Here goes:
 
Private Sub Workbook_Open() 'can only have one of these in the ThisWorkbook module
Dim p as String, dtRng as Range 'p is password, dtRng is range object for reference cell
Application.DisplayAlerts = False 'turn off dialog boxes
p = "mypassword" 'password to assign - replace this with the password you want
dtRng = Sheets("mySheet").Range("A1") 'cell containing date, replace "mySheet" with the sheet name
If Date >= DateValue(dtRng.value) And ActiveWorkbook.ProtectContents = False Then
    ActiveSheet.Protect Password:=p, DrawingObjects:=True, Contents:=True, Scenarios:=True 'protect sheet
    ActiveWorkbook.Protect Password:=p, Structure:=True, Windows:=False 'protect workbook
    ActiveWorkbook.SaveAs(Me.Name, , p) 'save with password protection
    Me.Close 'close
End If
Application.DisplayAlerts = True 'turn on dialog boxes again
End Sub

Open in new window

0
Eric ZwiekhorstSAP Business ConsultantCommented:
Hi McOz, it looks Ok.. I think Bright should be able to work with this and understand what is happening,

if not
Bright:

the dim has to come above just under the other dim you might have in the macro already existing.
there you can paste all code exept the end sub. This is already in the code.
Because you close the workbook after protecting you do not need to worry about the other code in the macro (Workbook_Open)

Kind regards

Eric
0
Bright01Author Commented:
Eric,

Thank you.

Just so I am clear;

1.) I put this line prior/above to the other code's Dim:
Dim p as String, dtRng as Range 'p is password, dtRng is range object for
and remove the End Sub.  
and
2.) The Date in "A1"; which worksheet do I put that on?  I have multiple ones.
0
Eric ZwiekhorstSAP Business ConsultantCommented:
Bright,

1) You put the DIM AFTER the other dims. followed by the code

2) you do not put it in the worksheet but in the workbook if you need to check the date on several sheets we might need to build a loop to check all sheets, if it is a few you can recopy the doe with each time another worksheet as base for date check

Kind regards

Eric
0
McOzCommented:
Jim, you can put that on the sheet of your choosing (whatever makes the most sense in your application), just make sure to update the code with the name of the sheet.

ALSO, I just had a "duh!" moment thinking about this:
After applying the protection and saving the workbook, this code closes it as well. It does this based on the value of a cell. So the only way to unlock the workbook is to open it with the password, then go change the date in the cell, and unprotect the sheets and workbook using the password.

However, if you open the workbook with the password, the Workbook_open event will fire, causing it to check the date (which is still the same as it was) and immediately close the workbook again.

In addition, you said there are multiple sheets in your workbook, and this code will only protect the Active sheet. In light of this, may I propose one further amendment to the code:
Private Sub Workbook_Open() 'can only have one of these in the ThisWorkbook module
Dim p as String, dtRng as Range 'p is password, dtRng is range object for reference cell
Application.DisplayAlerts = False 'turn off dialog boxes
p = "mypassword" 'password to assign - replace this with the password you want
dtRng = Sheets("mySheet").Range("A1") 'cell containing date, replace "mySheet" with the sheet name
If Date >= DateValue(dtRng.value) And ThisWorkbook.ProtectContents = False Then
    For each s in Sheets 'loops through all sheets, protecting them
        s.Protect Password:=p, DrawingObjects:=True, Contents:=True, Scenarios:=True
    Next
    ActiveWorkbook.Protect Password:=p, Structure:=True, Windows:=False 'protect workbook
    ActiveWorkbook.SaveAs(Me.Name, , p) 'save with password protection
End If
Application.DisplayAlerts = True 'turn on dialog boxes again
End Sub

Open in new window


Good luck! Thanks all for the good teamwork.
0
Bright01Author Commented:
Great job guys.  McOz, I like your idea of protecting each sheet.  My splashsheet comes up automatically when you launch the workbook and has a required "accept" button so if that screen is actually locked, no other worksheet should be accessable because the sheet is now locked....right?  So I think I can use either approach.

What I'm confused about is the following.  In THISWORKBOOK, I already have this macro.  Now how do I incorporate both Macros in THISWORKBOOK?

Private Sub Workbook_Open()
    Sheets("Splash").Select
    Application.OnTime Now() + TimeSerial(0, 0, 1), "module1.ShowForm"

   
    End Sub

'This code opens the workbench on the splash screen and displays the disclaimer
0
McOzCommented:
I would do the date check first, like this:
Private Sub Workbook_Open()
    
    'check for date, lock workbook if date exceeded
    Dim p As String, dtRng As Range 'p is password, dtRng is range object for reference cell
    Application.DisplayAlerts = False 'turn off dialog boxes
    p = "mypassword" 'password to assign - replace this with the password you want
    dtRng = Sheets("mySheet").Range("A1") 'cell containing date, replace "mySheet" with the sheet name
    If Date >= DateValue(dtRng.Value) And ThisWorkbook.ProtectContents = False Then
        For Each s In Sheets 'loops through all sheets, protecting them
            s.Protect Password:=p, DrawingObjects:=True, Contents:=True, Scenarios:=True
        Next
        ThisWorkbook.Protect Password:=p, Structure:=True, Windows:=False 'protect workbook
        ThisWorkbook.SaveAs Me.Name, , p 'save with password protection
    End If
    Application.DisplayAlerts = True 'turn on dialog boxes again
    
    'display splashscreen
    Sheets("Splash").Select
    Application.OnTime Now() + TimeSerial(0, 0, 1), "module1.ShowForm"

End Sub

Open in new window

0
Bright01Author Commented:
Ok...just tested it and two things; I have a bunch of hidden sheets.  When I open the workbook, it apparently is giving me an error for those worksheets that are hidden.  Is there a way to lock the workbook without locking the worksheets or a way to only lock certain worksheets that I can designate?  That way I'll lock a few key worksheets that are not hidden.

Thanks again for all the effort here.

B.
0
McOzCommented:
OK, to make it lock all visible sheets:
Private Sub Workbook_Open() 
     
    'check for date, lock workbook if date exceeded 
    Dim p As String, dtRng As Range 'p is password, dtRng is range object for reference cell 
    Application.DisplayAlerts = False 'turn off dialog boxes 
    p = "mypassword" 'password to assign - replace this with the password you want 
    dtRng = Sheets("mySheet").Range("A1") 'cell containing date, replace "mySheet" with the sheet name 
    If Date >= DateValue(dtRng.Value) And ThisWorkbook.ProtectContents = False Then 
        For Each s In Sheets 'loops through all sheets, protecting them 
            If s.Visible Then s.Protect Password:=p, DrawingObjects:=True, Contents:=True, Scenarios:=True 
        Next 
        ThisWorkbook.Protect Password:=p, Structure:=True, Windows:=False 'protect workbook 
        ThisWorkbook.SaveAs Me.Name, , p 'save with password protection 
    End If 
    Application.DisplayAlerts = True 'turn on dialog boxes again 
     
    'display splashscreen 
    Sheets("Splash").Select 
    Application.OnTime Now() + TimeSerial(0, 0, 1), "module1.ShowForm" 
 
End Sub

Open in new window


OR to make it lock certain specified sheets:
Private Sub Workbook_Open() 
     
    'check for date, lock workbook if date exceeded 
    Dim p As String, dtRng As Range, lSheets(3) as String 'p is password, dtRng is range object for reference cell 
    Application.DisplayAlerts = False 'turn off dialog boxes 
    p = "mypassword" 'password to assign - replace this with the password you want 
    dtRng = Sheets("mySheet").Range("A1") 'cell containing date, replace "mySheet" with the sheet name 

    Dim lSheets(3) 'array to store the sheets you want locked. Change 3 to whatever number
    lSheets(0)="Sheet1" 'specify the sheet names
    lSheets(1)="Sheet2"
    lSheets(2)="Sheet3"

    If Date >= DateValue(dtRng.Value) And ThisWorkbook.ProtectContents = False Then 
        For Each s In lSheets 'loops through all specified sheets, protecting them 
            Sheets(s).Protect Password:=p, DrawingObjects:=True, Contents:=True, Scenarios:=True 
        Next 
        ThisWorkbook.Protect Password:=p, Structure:=True, Windows:=False 'protect workbook 
        ThisWorkbook.SaveAs Me.Name, , p 'save with password protection 
    End If 
    Application.DisplayAlerts = True 'turn on dialog boxes again 
     
    'display splashscreen 
    Sheets("Splash").Select 
    Application.OnTime Now() + TimeSerial(0, 0, 1), "module1.ShowForm" 
 
End Sub

Open in new window


Cheers
0
Bright01Author Commented:
McOz,

Thank you so much for sticking with me on this.  I copied and pasted the code to reset passwords on all visable sheets; and I put 4/1/2011 in the A1 Field on the "Splash" worksheet.  I am so sorry;  Unfortuntately when I open it I get a Compile Error in Hidden Module: Workbook.  I do have the project locked; could that be the problem?  I'm also running 2010 Excel 64-bit...........

Any ideas?

B.
0
McOzCommented:
Sorry Bright, error in my code:

ThisWorkbook.ProtectContents makes no sense and gives the error because ProtectContents is a property of Sheet objects. Instead we will check for ThisWorkbook.ProtectStructure:
Private Sub Workbook_Open() 
     
    'check for date, lock workbook if date exceeded 
    Dim p As String, dtRng As Range 'p is password, dtRng is range object for reference cell 
    Application.DisplayAlerts = False 'turn off dialog boxes 
    p = "mypassword" 'password to assign - replace this with the password you want 
    dtRng = Sheets("mySheet").Range("A1") 'cell containing date, replace "mySheet" with the sheet name 
    If Date >= DateValue(dtRng.Value) And ThisWorkbook.ProtectStructure = False Then 
        For Each s In Sheets 'loops through all sheets, protecting them 
            If s.Visible Then s.Protect Password:=p, DrawingObjects:=True, Contents:=True, Scenarios:=True 
        Next 
        ThisWorkbook.Protect Password:=p, Structure:=True, Windows:=False 'protect workbook 
        ThisWorkbook.SaveAs Me.Name, , p 'save with password protection 
    End If 
    Application.DisplayAlerts = True 'turn on dialog boxes again 
     
    'display splashscreen 
    Sheets("Splash").Select 
    Application.OnTime Now() + TimeSerial(0, 0, 1), "module1.ShowForm" 
 
End Sub

Open in new window


Give it a run!
-Oz
0
Bright01Author Commented:
McOz,

Sorry for the delay.  I took a new workbook, put the code above in the ThisWorkbook Module and set a date out on the 5th of April . 04/05/2011.  I'm testing it with a date outside the lock date.  Then I close and reopen.  I get a "Object variable or With Block variable not set" error.  Any advice?

Thank you,

B.
0
McOzCommented:
OK, I just tested it too (which I should have done first, forgive me!)

The issue is with this line:
dtRng = Sheets("mySheet").Range("A1") 'cell containing date, replace "mySheet" with the sheet name

Open in new window


Should be:
Set dtRng = Sheets("mySheet").Range("A1") 'cell containing date, replace "mySheet" with the sheet name

Open in new window


Try it now.
0
Bright01Author Commented:

McOz,

I've tested it and realized the problem is a little more complicated.  If I have a workbook that is already password protected, this code and the change only changes the password in the worksheet(s)..... it doesn't lock the Workbook.  Can you comment on that?  This may be something that is too complex.



Private Sub Workbook_Open()
 
    'check for date, lock workbook if date exceeded
    Dim p As String, dtRng As Range 'p is password, dtRng is range object for reference cell
    Application.DisplayAlerts = False 'turn off dialog boxes
    p = "jam" 'password to assign - replace this with the password you want
   Set dtRng = Sheets("mysheet").Range("A1") 'cell containing date, replace
    If Date >= DateValue(dtRng.Value) And ThisWorkbook.ProtectStructure = False Then
        For Each s In Sheets 'loops through all sheets, protecting them
            If s.Visible Then s.Protect Password:=p, DrawingObjects:=True, Contents:=True, Scenarios:=True
        Next
        ThisWorkbook.Protect Password:=p, Structure:=True, Windows:=False 'protect workbook
        ThisWorkbook.SaveAs Me.Name, , p 'save with password protection
    End If
    Application.DisplayAlerts = True 'turn on dialog boxes again
     
'display splashscreen
'Sheets("mysheet").Select
'Application.OnTime Now() + TimeSerial(0, 0, 1), "module1.ShowForm"
 
End Sub
0
McOzCommented:
OK Bright, here's the ultimate:

1. On open, code checks a named range called "checkDate" to see if the date is in the past. If so, all visible sheets are protected, the workbook is protected, and then saved with password protection. Once they close it, they can no longer open without the password.

2. An authorised user who knows the password is then required to open the WB again to change the value of the cell.

3. When the cell "checkDate" is changed, if the new date is in the future the code unprotects all visible sheets using the same password, unprotects the workbook, and saves itself with no password again. Now it is accessible to anyone.

You will need to name your date cell "checkDate". This allows it to be on any sheet, and if you want to change the cell reference later, you can do it in the Names Manager instead of having to mess with the code. Then, paste all of this code into the ThisWorkbook module:
Const p = "jam"
Private Sub Workbook_Open()
 
    'check for date, lock workbook if date exceeded
    Dim p As String, dtRng As Range 'p is password, dtRng is range object for reference cell
    Application.DisplayAlerts = False 'turn off dialog boxes
   Set dtRng = Range("checkDate") 'cell containing date, replace
    If Date >= DateValue(dtRng.Value) And ThisWorkbook.ProtectStructure = False Then
        For Each s In Sheets 'loops through all sheets, protecting them
            If s.Visible Then s.Protect Password:=p, DrawingObjects:=True, Contents:=True, Scenarios:=True
        Next
        ThisWorkbook.Protect Password:=p, Structure:=True, Windows:=False 'protect workbook
        ThisWorkbook.SaveAs Me.FullName, , p 'save with password protection
    End If
    Application.DisplayAlerts = True 'turn on dialog boxes again
     
'display splashscreen
Sheets("mysheet").Select
Application.OnTime Now() + TimeSerial(0, 0, 1), "module1.ShowForm"
 
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    'check if date range was changed
    Application.DisplayAlerts = False
    If Not Application.Intersect(Target, Range("checkDate")) Is Nothing Then
        If Date < DateValue(Target.Value) Then
        For Each s In Sheets 'loops through all sheets, nuprotecting them
            If s.Visible Then s.Unprotect Password:=p
        Next
        ThisWorkbook.Unprotect Password:=p 'unprotect workbook
        ThisWorkbook.SaveAs Filename:=Me.FullName, Password:="" 'save workbook without password
        End If
    End If
    Application.DisplayAlerts = True
End Sub

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Bright01Author Commented:
Great work!  Thanks for hanging in there with me.

B.
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.