prevent a user from accessing workbook after certain period of time

[csilabgirl]

Excel 2002.

I have the following code in place to prevent a user from having access to a workbook past a certain date. However, I just found a major flaw. If the user changes the date on their computer to a date prior to 07/30/11 then they can trick excel and still access the file. Does anyone else have any ideas for a way to put something in place that will not allow a user to access a workbook after a certain date?

Private Sub Workbook_Open()
If Date > DateValue("7/30/11") Then
MsgBox ("User access for the October 1, 2010 - July 30, 2011 contract has expired. Please contact Nicole at xxx-xxx-xxxx for renewal information")
Exit Sub

Thank you for your time

 

[Jaafar Tribak]

Excel 2002.

I have the following code in place to prevent a user from having access to a workbook past a certain date. However, I just found a major flaw. If the user changes the date on their computer to a date prior to 07/30/11 then they can trick excel and still access the file. Does anyone else have any ideas for a way to put something in place that will not allow a user to access a workbook after a certain date?

Private Sub Workbook_Open()
If Date > DateValue("7/30/11") Then
MsgBox ("User access for the October 1, 2010 - July 30, 2011 contract has expired. Please contact Nicole at xxx-xxx-xxxx for renewal information")
Exit Sub

Thank you for your time

I don't think you can solve this even checking the BIOS date as this I think changes when the date is changed via the OS.

The only thing I can think of is for the code to check the date in a time server.

 

[GTO]

Not much of an idea, and certainly a malicious user can get by, but if for fairly compliant users, maybe check to see if we have suddenly gone back in time?

Option Explicit
    
Private Sub Workbook_Open()
    
    With Sheet1
        
        If Not .Cells(1, 2).Value = "RAN" Then
            setup
            .Cells(1, 2).Value = "RAN"
            ThisWorkbook.Save
            GoTo FirstRun
        End If
        '// IF today exceeds arbitrary date OR suddenly the PC's date is earlier    //
        '// than it was last time we ran...                                         //
        If Date > #12/31/2011# Or CLng(.Cells(1).Value) > CLng(Date) Then
            MsgBox "Call..."
            Exit Sub ' or whatever
        Else
            .Cells(1).Value = CLng(Date)
            ThisWorkbook.Save
        End If
FirstRun:
    End With
End Sub
    
Sub setup()
    Sheet1.Range("A1").NumberFormat = "0"
    Sheet1.Cells(1).Value = CLng(Date)
    Sheet1.Visible = xlSheetVeryHidden
End Sub

A great weekend to all,

Mark

 

[csilabgirl]

Thank you both of you for responding. I actually thought of this idea over the weekend which I think should work. Each time the workbook is opened it updates the current date on Sheet "D". On sheet "D" in cell A1 I have =TODAY(). If someone all of a sudden cant get in and figures out its a date thing and tries to set the computer date back, its too late because the date is already set in the workbook (this workbook automatically saves on close). GTO, I will keep your code as it might come in handy for something else. Thank you!

Private Sub Workbook_Open()

If Sheets("D").Range("B1") > DateValue("11/30/11") Then
MsgBox ("User access for the October 1, 2010 - September 30, 2011 contract has expired. Please contact Nicole at for renewal information")
Sheets("D").Range("B2").Value = InputBox("Chromosomal Laboratories Contract Renewal Number")
Else:
Sheets("D").Range("A1").Copy
Sheets("D").Range("B1").PasteSpecial Paste:=xlPasteValues
Exit Sub
End If