Using excel to expire a worksheet

Question

I have an excel worksheet that I need to set an expiration date on so that when the expiration date occurs the file is rendered useless and they must contact me to get a new version of the file.

I have written a script that forces the first worksheet to be displayed and hide sheet two (which contains the date) if macros is not enabled and the sheet reads that macros must be enabled to continue. Once they enable macros sheet two becomes visible and they can utilize the data. Once macros is enabled the script runs the expiration date command and if the current date is passed the expiration date a message window is displayed alerting the user their file as expired. The problem is that after this message window is closed excel prompts the user to save, don't save, or cancel. If the user selects cancel then the next message box that appears is the expiration date window with the expiration date reporting they have negative days left. They can then close that window and gain access to the calculator.

I have dabbled with the 'ActiveWorkbook.Save = True' feature below but to no avial.

Private Sub Workbook_BeforeClose(Cancel As Boolean) ActiveWorkbook.Saved = True End Sub

It disables my worksheet that requires the user to enable macros and that is a no go, basically renders the file useless.

I have attached the VBA script and was hoping you guys could help out.

Thanks so much!

Here is the code:

Private Const dsWarningSheet As String = "sheet1" 'Enter name of the Entry/Warning Page

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

For Each ds In ActiveWorkbook.Sheets
If LCase(dsWarningSheet) = LCase(ds.Name) Then
ds.Visible = True
End If
Next

End Sub

Private Sub Workbook_Open()

Dim myCount        'This line of code is optional
Dim i                     'This line of code is optional
Dim Edate As Date
On Error Resume Next

myCount = Application.Sheets.Count
For i = 2 To myCount
Sheets(i).Visible = True
If i = myCount Then
Sheets(1).Visible = xlVeryHidden
End If
Next i

Edate = Format("13/01/2012", "DD/MM/YYYY") ' Replace this with the date you want
If Date > Edate Then
MsgBox ("This worksheet was valid upto " & Format(Edate, "dd-mmm-yyyy") & " and will be closed: Please contact John Smith at Company ABC to purchase a new version of this calculator")
ActiveWorkbook.Close
End If
If Edate - Date < 30 Then
MsgBox ("This worksheet expires on " & Format(Edate, "dd-mmm-yyyy") & " You have " & Edate - Date & " Days left")
End If

End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)

Dim myCount        'This line of code is optional
Dim i                     'This line of code is optional
On Error Resume Next
myCount = Application.Sheets.Count
Sheets(1).Visible = True
Range("A1").Select
For i = 2 To myCount
Sheets(i).Visible = xlVeryHidden
If i = myCount Then
End If
Next i
ActiveWorkbook.Save

End Sub

Private Sub Workbook_Openxx()

Dim myCount        'This line of code is optional
Dim i                     'This line of code is optional
On Error Resume Next

myCount = Application.Sheets.Count
For i = 2 To myCount
Sheets(i).Visible = True
If i = myCount Then
Sheets(1).Visible = xlVeryHidden
End If
Next i

End Sub

Answer 1

Close the workbook and tell it not to save. See below

Dim wb as workbook
set wb = <yourworkbook>

wb.Close SaveChanges:=Excel.XlSaveAction.xlDoNotSaveChanges 

Answer 2

this is my first post here. I created a solution for this issue and I want to share it with you.

If you want to set an expiration date for an Excel Workbook, Add-in etc you can use the below code which will give users a message and then will delete, close and unistall the add-in if it is the case.

You just have to add it in the Workbook_Open event of the file and then put a password on the VBA code of the project.

When expiration date occurs and user opens the file, it will be completely erased.

Private Sub Workbook_Open()

Dim exdate As Date
Dim i As Integer

anul = 2015   ' (year) change these according to your expiration date
luna = 11     '(month)
ziua = 1      '(day)     

exdate = DateSerial(anul, luna, ziua)

If Date > exdate Then
    MsgBox ("The application " & ThisWorkbook.Name & " has expired !" & vbNewLine & vbNewLine _
    & "Expiration set up date is: " & exdate & " :)" & vbNewLine & vbNewLine _
    & "Contact xxx person(you) to renew the version !"), vbCritical, ThisWorkbook.Name

    expired_file = ThisWorkbook.Path & "\" & ThisWorkbook.Name


   On Error GoTo ErrorHandler
With Workbooks(ThisWorkbook.Name)
    If .Path <> "" Then

        .Saved = True
        .ChangeFileAccess xlReadOnly

        Kill expired_file

        'get the name of the addin if it is addin and unistall addin
        If Application.Version >= 12 Then
         i = 5
        Else: i = 4
        End If

        If Right(ThisWorkbook.Name, i) = ".xlam" Or Right(ThisWorkbook.Name, i) = ".xla" Then
            wbName = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - i)
             'uninstall addin if it is installed
             If AddIns(wbName).Installed = True Then
                AddIns(wbName).Installed = False
              End If
        End If

        .Close

    End If
End With

Exit Sub

End If

Exit Sub

ErrorHandler:
MsgBox "Fail to delete file.. "
Exit Sub

End Sub

Now, my question would be, how to write a code to check the computer on which the user uses the file or the date when he left the company ?

I would like some kind of code that will not allow users to use the file on other pc's than the ones from work. (in order to not take with them the excel tools when they leave the company).