expiration date and Kill

[av8tordude]

According to the links above, it claims I can use the two codes in conjuctions. Can someone assist me in modifying this code to delete my workbook upon expiration date. From my understanding of the kill code, the user has to execute the code by pressing ALT F8. Since the workbook is a trial, the user doesn't need to have the workbook still on there hard drive.

Also, is it possible to provide the user a countdown warning to warn the user the number of days remaining before the workbook is rendered useless and deleted? I don't want the user to continue trying to gain access to the workbook after the trial has exprired.

Thank you for your help

Option Explicit
Sub KillMe()
With ThisWorkbook
.Saved = True
.ChangeFileAccess Mode:=xlReadOnly
Kill .FullName
.Close False
End With
End Sub

Option Explicit

Private Sub Workbook_Open()
Dim StartTime#, CurrentTime#

'*****************************************
'SET YOUR OWN TRIAL PERIOD BELOW
'Integers (1, 2, 3,...etc) = number of days use
'1/24 = 1Hr, 1/48 = 30Mins, 1/144 = 10Mins use

Const TrialPeriod# = 30 '< 30 days trial

'set your own obscure path and file-name
Const ObscurePath$ = "C:\"
Const ObscureFile$ = "TestFileLog.Log"
'*****************************************

If Dir(ObscurePath & ObscureFile) = Empty Then
StartTime = Format(Now, "#0.#########0")
Open ObscurePath & ObscureFile For Output As #1
Print #1, StartTime
Else
Open ObscurePath & ObscureFile For Input As #1
Input #1, StartTime
CurrentTime = Format(Now, "#0.#########0")
If CurrentTime < StartTime + TrialPeriod Then
Close #1
Exit Sub
Else
If [A1] <> "Expired" Then
MsgBox "Sorry, your trial period has expired - your data" & vbLf & _
"will now be extracted and saved for you..." & vbLf & _
"" & vbLf & _
"This workbook will then be made unusable."
Close #1
SaveShtsAsBook
[A1] = "Expired"
ActiveWorkbook.Save
Application.Quit
ElseIf [A1] = "Expired" Then
Close #1
Application.Quit
End If
End If
End If
Close #1
End Sub

Sub SaveShtsAsBook()
Dim Sheet As Worksheet, SheetName$, MyFilePath$, N&
MyFilePath$ = ActiveWorkbook.Path & "\" & _
Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
With Application
.ScreenUpdating = False
.DisplayAlerts = False
On Error Resume Next '<< a folder exists
MkDir MyFilePath '<< create a folder
For N = 1 To Sheets.Count
Sheets(N).Activate
SheetName = ActiveSheet.Name
Cells.Copy
Workbooks.Add (xlWBATWorksheet)
With ActiveWorkbook
With .ActiveSheet
.Paste
'//N.B. to remove all the cell formulas,
'//uncomment the 4 lines of code below...
'With Cells
'.Copy
'.PasteSpecial Paste:=xlPasteValues
'End With
.Name = SheetName
[A1].Select
End With
'save book in this folder
.SaveAs Filename:=MyFilePath _
& "\" & SheetName & ".xls"
.Close SaveChanges:=True
End With
.CutCopyMode = False
Next
End With

[av8tordude]

I was hoping for some help with this....anyone?

[anandbohra]

explore this code. It will be very helpful for you.

http://vbaexpress.com/kb/getarticle.php?kb_id=475

[johnske]

According to the links above, it claims I can use the two codes in conjuctions. Can someone assist me in modifying this code to delete my workbook upon expiration date. From my understanding of the kill code, the user has to execute the code by pressing ALT F8. Since the workbook is a trial, the user doesn't need to have the workbook still on there hard drive.

Also, is it possible to provide the user a countdown warning to warn the user the number of days remaining before the workbook is rendered useless and deleted? I don't want the user to continue trying to gain access to the workbook after the trial has exprired...

No, the kill code can be executed completely automatically with a Workbook_Open event.

You're missing the point here - the whole idea of having it like this is that if the trial period has expired the workbook is left on the drive so that if they then want to pay for the "full" version they will be given instructions (by the person selling) on how to resuscitate the workbook (with all their data still intact) that is still on their hard-drive. If they don't want to pay it's really quite a simple exercise to delete it manually (a really small price to pay for the free use of your program) - part of the code has already saved all the data they have put into the workbook (after all, the data that was input during the trial period and any results you've allowed them to obtain from the data during that trial period really belongs to them). Apart from that, if they're too tight to pay for all the work you've done, then who gives a rats if they have to do a little work themselves to delete it manually?

Yes, you could give a countdown warning, but why bother? The only real effect for some ppl would be for them to try harder to find a way to get into the code (easily done if you know how) so they don't have to pay you - it's better to not let them know there trial period is almost up.

[av8tordude]

I was able to to modify the code to give a expired warning message and have the user enter a password to continue. I would like to modify the code to allow the user "X" amount of chances to enter a password to gain unrestricted access to the workbook, but if "x" amount of attempts fail, the work book would be deleted from the hard drive. If the user enters the password correctly, the user has unrestricted access to the workbook without being prompted for a password again. The code below is setup for only one chance to enter a password correctly and if entered incorrectly, the workbook is deleted. (obviously, not a wise option)

Any help would be appreciated.



Private Sub Workbook_Open()
Dim StartTime#, CurrentTime#

Const TrialPeriod# = 1 '< 1 days trial

Const ObscurePath$ = "C:\"
Const ObscureFile$ = "LBFileLog.Log"

If Dir(ObscurePath & ObscureFile) = Empty Then
StartTime = Format(Now, "#0.#########0")
Open ObscurePath & ObscureFile For Output As #1
Print #1, StartTime
Else
Open ObscurePath & ObscureFile For Input As #1
Input #1, StartTime
CurrentTime = Format(Now, "#0.#########0")
If CurrentTime < StartTime + TrialPeriod Then
Close #1
Exit Sub
Else
If [A1] <> "Expired" Then
Call MsgBox("This book is expired. Please enter the password to continue", vbCritical, "EXPIRED!")
Resp = InputBox("Please enter the password to continue")
If Resp = "password" Then
Exit Sub
Else: Application.Quit
Call Killme
End If
End If
End If
End If
End Sub

Sub KillMe()
With ThisWorkbook
.Saved = True
.ChangeFileAccess Mode:=xlReadOnly
Kill .FullName
.Close False
End With
End Sub