Locking a Workbook on a particular date

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

Select allOpen in new window

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

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

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

Select allOpen in new window

Cheers

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  

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

Zwiekhorst,

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

Thanks,

B.

The code needs to go in "This Workbook".

Cheers

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.

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

Select allOpen in new window

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

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.

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

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

Select allOpen in new window

Good luck! Thanks all for the good teamwork.

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

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

Select allOpen in new window

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.

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

Select allOpen 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

Select allOpen in new window

Cheers

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.

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

Select allOpen in new window

Give it a run!
-Oz

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.

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

Select allOpen in new window

Should be:

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

Select allOpen in new window

Try it now.

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

Great work!  Thanks for hanging in there with me.

B.