Time Trial for Excel Sheets

[torque]

Is there a way to make an Excel sheet expire (ie. become useless or password protected) after a certain number of uses or days?

thanks!

 

[HalfAce]

Hi Dave,
If you really want to make it permanant, you could use something like

Private Sub Workbook_Open() 
If Date < [IV65536].Value Or Date > [IV65535].Value Then 
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
ws.Select
ActiveSheet.Unprotect
Cells.Clear
Next ws
ActiveWorkbook.Close True
Else: [IV65536].Value = Date 
End If 
End Sub

(I recommend you only test this out on a dummy workbook!)
Nope, my name's not McKendrick. Don't know any McKendricks here either, but I suppose that doesn't mean there aren't any. (If there are, they must keep pretty quiet 'cause you're right, it's a pretty small town.) You familiar with our little neck of the woods here?
Dan

 

[Stromma]

Hi

Here's a different approach:

Create a dummy book to test on. Name 3 sheets: Sorry, Count & Data. If macro's disabled the only visible sheet will be sheet"Sorry". Sheets("Count") is a hidden sheet that count the times the book has been opened. Sheets("Data") is your important sheet.

Now, every time the book opens Sheets("Count").Range"A1") = + 1.

In old test i did the limit to open the book is set to 30 times. After that it will ask for a serial number. If correct serial number is entered it will work as normal, otherwise it will prompt for a correct serial number and close. After 60 times all important in the book will be deleted.

Put this in: ThisWorkbook:

Private Sub Workbook_Open()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
'Secret Count Sheet For Counting Times Open
    Sheets("Count").Visible = True
'If Sheets("Count").Range("A1")= 500 Then WorkBook Is Registered. Open Workbook
    If Sheets("Count").Range("B1") = "Registered" Then
    Sheets("Count").Range("A1") = 500
    Run "UnLocked" 'GoTo Private Sub UnLocked
    Exit Sub
    End If
'If It Not Registered After 60 Openings Delete Important Sheets. Set As Many Times You Prefer.
    If Sheets("Count").Range("A1") > 60 Then 'Set As Many Times You Prefer Here.
    Run "LockAndDelete" 'GoTo Private Sub LockAndDelete
    Exit Sub
    End If
'After 30 Times Opening Ask For A Serial Number, in this ex: "SERIAL".
    If Sheets("Count").Range("A1") > 30 Then 'Set As Many Times You Prefer Here.
    Serial = InputBox("This Workbook is limited to be opened 30 times unregistered!" & Chr(13) & Chr(13) & _
    "You have now opened this Workbook " & Sheets("Count").Range("A1") & " times!" & Chr(13) & Chr(13) & _
    "If you open this Workbook more than 60 times it will be deleted!" & Chr(13) & Chr(13) & _
    "Please enter your Serial Number!")
'If SERIAL Is Wrong Show Only Sheets("Sorry")
    If Serial <> "SERIAL" Then 'Change Serial To hat You Prefer Here.
    Run "WrongSerial" 'GoTo Private Sub WrongSerial
    Exit Sub
    Else
'If SERIAL Is Wrong Show Only Sheets("Sorry")
    If Serial = "SERIAL" Then 'Change Serial To hat You Prefer Here.
    Run "Registered" 'GoTo Private Sub Registered
    Exit Sub
    End If
    End If
    End If
    Sheets("Data").Visible = True
    Sheets("Data").Select
    Sheets("Count").Range("A1") = Sheets("Count").Range("A1") + 1 'Count On Sheets("Count") + 1 Each Time Book Opens.
'Save Workbook To Prevent From Close Without Count
    ActiveWorkbook.Save
    Sheets("Sorry").Visible = xlVeryHidden
    Sheets("Count").Visible = xlVeryHidden
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Application.ScreenUpdating = False
    Sheets("Sorry").Visible = True
    Sheets("Sorry").Select
    Range("A1").Select
    Sheets("Data").Visible = xlVeryHidden
    Sheets("Count").Visible = xlVeryHidden
'Save Workbook To Prevent From Close Without Saving
    ActiveWorkbook.Save
    Application.ScreenUpdating = True
End Sub

This goes into a module:

Private Sub Registered()
'If Sheets("Count").Range("A1")= 500 Then WorkBook Is Registered. Open Workbook
    Sheets("Data").Visible = True
    Sheets("Data").Select
    Sheets("Count").Range("B1") = "Registered"
    Sheets("Count").Range("A1") = 500
    Sheets("Sorry").Visible = xlVeryHidden
    Sheets("Count").Visible = xlVeryHidden
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "Thank You for register this product!"
End Sub
Private Sub Unlocked()
'If Right Serial Is Entered Register Workbook. Open Workbook
    Sheets("Data").Visible = True
    Sheets("Data").Select
    Sheets("Count").Range("B1") = "Registered"
    Sheets("Count").Range("A1") = 500
    Sheets("Sorry").Visible = xlVeryHidden
    Sheets("Count").Visible = xlVeryHidden
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
Private Sub WrongSerial()
'If Wrong Serial Is Entered Show Only Sheets("Sorry") And Continue To Count Openings.
    MsgBox "You have entered wrong serial Number! " & Chr(13) & Chr(13) & _
    "This WorkBook will now close!", vbCritical
    Sheets("Sorry").Visible = True
    Sheets("Sorry").Select
    Sheets("Data").Visible = xlVeryHidden
    Sheets("Count").Visible = xlVeryHidden
    Sheets("Count").Range("A1") = Sheets("Count").Range("A1") + 1
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.Quit
    ThisWorkbook.Close SaveChanges:=True
End Sub
Private Sub LockAndDelete()
Dim sFileName As String, sFilePath As String
 'If Not Registerer After Opening 60 Times Delete Sheets("Count") And ("Data")
    MsgBox "This Workbook will now close and all data will be lost!", vbCritical
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Sheets("Sorry").Visible = True
    Sheets("Sorry").Select
    Sheets("Count").Visible = True
    Sheets("Data").Visible = True
    Sheets("Count").Delete
    Sheets("Data").Delete
    sFileName = ThisWorkbook.Name
    sFilePath = ThisWorkbook.Path
    ActiveWorkbook.SaveAs (sFilePath & sFileName), Password:="locked"
    Application.Quit
    ThisWorkbook.Close SaveChanges:=True
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

/Roger

 

[HalfAce]

Hi torque,
To be able to see the VeryHidden sheet again, you need to use a little more code.
Make another button and assign this to it.

Sub ShowMyVeryHiddenSheet()
Sheets("YourSheetName").Visible = True
Sheets("YourSheetName").Select
End Sub

(Sorry for not including this earlier.)
Dan

 

[HalfAce]

Hi Roger,
I just went through your routine and it's pretty good.
Looks like you've pretty much got everything covered.
You did a good job writing that.
Dan

 

[daveus]

Thanks HalfAce and Stromma, is there a way to actually delete code within modules, e.g. remove all the subs and functions from the vba code. Ideally, I would just like to remove a couple modules and a worksheet. Any thoughs...This is a good start though...

 

[Smitty]

See Chip Pearson's site for: How to Add or Delete Modules

Hope that helps,

Smitty

 

[daveus]

Ya, thanks Smitty, that did help. I had seen that before, I couldn't remember where I had found the info. That was it! Much thanks!

 

[Stromma]

Thanks HalfAce!

I got another versions around here somewhere thats based on date. But since that alreday have been covered earlier in this thread, i thought i post this as an alternative. It's easy enough to change this if anyone want based on date for example. With the VBA Project locked and secured i think it's pretty safe.

To be honest, i'm sure their are a lot of things in my code that can be done in a better way by most of you people around here. And if anyone want to use this, feel free to change the code so that it's suits your needs.

Just remember to always test it out on a dummy book first, so you don't lose important data and/or sheets!

/Roger

 

[daveus]

I tried Chip's code (above) to delete vba code...a module to be specific. I couldn't get it to work. Does anyone have anything else that might help me delete a module? I'd appreciate any help! Thanks...

Dave...

 

[Stromma]

Try this:

Sub SaveWithoutMacros()

'Purpose : To save a copy of the active workbook without macros

    Dim vFilename As Variant
    Dim wbActiveBook As Workbook
    Dim oVBComp As Object
    Dim oVBComps As Object


    On Error GoTo CodeError


    'Get a filename to save as
    vFilename = Application.GetSaveAsFilename(filefilter:="Microsoft Excel Workbooks,*.xls", _
                                              Title:="Save Copy Without Macros")

    If vFilename = False Then Exit Sub  'User chose Cancel

    ActiveWorkbook.SaveCopyAs vFilename
    Set wbActiveBook = Workbooks.Open(vFilename)


    'Now strip all VBA, modules, userforms from the copy

    Set oVBComps = wbActiveBook.VBProject.VBComponents

    For Each oVBComp In oVBComps
        Select Case oVBComp.Type
        Case 1, 2, 3  'Standard Module, Class Module, Userform
            oVBComps.Remove oVBComp
        Case Else
            With oVBComp.CodeModule    'Worksheet or workbook code module
                .DeleteLines 1, .CountOfLines
            End With
        End Select
    Next oVBComp

    wbActiveBook.Save

    MsgBox "A copy of your workbook has been created with all VBA code removed.", vbInformation, "Success!"

    Exit Sub

CodeError:
    MsgBox Err.Description, vbExclamation, "An Error Occurred"

End Sub

I'm not sure, but i think it's written by Daniel Klann.

This removes code , modules and forms.

/Roger