Free Microsoft Excel 2013
Quick Reference
Free Microsoft 2013 Quick Reference Guide

Free Microsoft Excel 2013 Quick Reference

Timebombing a workbook Results

I have a workbook that I want to make read access only after 365 days. I'm using the following code to do this:
Option Explicit


Private Const C_NUM_DAYS_UNTIL_EXPIRATION = 365



Sub TimeBombMakeReadOnly()

Dim ExpirationDate As String
Dim NameExists As Boolean

On Error Resume Next
ExpirationDate = Mid(ThisWorkbook.Names("ExpirationDate").Value, 2)
If Err.Number <> 0 Then
    ExpirationDate = CStr(DateSerial(Year(Now), _
        Month(Now), Day(Now) + C_NUM_DAYS_UNTIL_EXPIRATION))
    ThisWorkbook.Names.Add Name:="ExpirationDate", _
        RefersTo:=Format(ExpirationDate, "short date"), _
        Visible:=False
    NameExists = False
Else
    NameExists = True
End If

If CDate(Now) >= CDate(ExpirationDate) Then
    If NameExists = False Then
        ThisWorkbook.Save
    End If
    ThisWorkbook.ChangeFileAccess xlReadOnly
End If

End Sub
What I need help with is adding some additional code to prevent someone from saving the workbook under a differnt name. Currently if someone tried to enter data after the alloted time period, it would allow them to in any "unlocked" cells. When exiting or trying to save the file with this new data, they will get a message stating something to the effect that this is a read only file would you like to save as another name, which would allow the user to circumvent what I'm trying to accomplish. The end result would be they'd need a new spreadsheet. I hope this makes sense. Any assistance would be greatly appreciated!

the following webpage has some good ideas on how to timebomb a workbook, but i was wondering if there was any way to modify the code to bomb the workbook if it is opened on a machine that is not authorized. thanks.

http://www.cpearson.com/excel/WorkbookTimeBomb.aspx

I have created an Excel Workbook and this Workbook has a VBA code that enforces an expiry date of the workbook (TimeBomb from cpearson.com). So, if the expiry date has passed, the workbook will not open. But since it is VBA related, the expiry date will work only if one has enabled macros. If macros are disabled, the workbook will open regardless of the date.

So, is there a way for Excel to check if macros are enabled? and is there a way for Excel not to open the workbook, if the macros are disabled?

I hope this question is for this forum.

Appreciate the help.

Regards.

I am using Chip Pearson's code for setting a timebomb. However I am getting a run-time error '1004' Application-defined or object-defined error when the ExpirationDate is set on the second line of execution. Shouldn't this run as is or am I missing something here? I don't get why the error isn't handled with the "On Error" code ...

Sub
TimeBombMakeReadOnly()
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' TimeBombMakeReadOnly
' This procedure uses a defined name to store the expiration
' date and if the workbook has expired, makes the workbook
' read-only.
'
' Source: http://www.cpearson.com/excel/workbooktimebomb.aspx
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    Dim ExpirationDate As String
    Dim NameExists As Boolean

    On Error Resume Next
    ExpirationDate = Mid(ThisWorkbook.Names("ExpirationDate").Value, 2)
    If Err.Number <> 0 Then
        '''''''''''''''''''''''''''''''''''''''''''
        ' Name doesn't exist. Create it.
        '''''''''''''''''''''''''''''''''''''''''''
        ExpirationDate = CStr(DateSerial(Year(Now), _
                                         Month(Now), Day(Now) + C_NUM_DAYS_UNTIL_EXPIRATION))
        ExpirationDate = CStr(DateSerial(Year(C_WORKBOOK_ISSUE_DATE), _
                                         Month(C_WORKBOOK_ISSUE_DATE), Day(C_WORKBOOK_ISSUE_DATE) +
C_NUM_DAYS_UNTIL_EXPIRATION))
        ThisWorkbook.Names.Add Name:="ExpirationDate", _
                               RefersTo:=Format(ExpirationDate, "short date"), _
                               Visible:=False
        NameExists = False
    Else
        NameExists = True
    End If

    ''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' If the today is past the expiration date, make the
    ' workbook read only. We need to Save the workbook
    ' to keep the newly created name intact.
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''
    If CDate(Now) >= CDate(ExpirationDate) Or CDate(Now) < CDate(C_WORKBOOK_ISSUE_DATE) Then
        If NameExists = False Then
            ThisWorkbook.Save
        End If
        ThisWorkbook.ChangeFileAccess xlReadOnly
    End If
    ThisWorkbook.Names.Add.Delete
End Sub



No luck finding an answer? You could always try Google.