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$ = "[Link]"
'*****************************************
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"
[Link]
[Link]
ElseIf [A1] = "Expired" Then
Close #1
[Link]
End If
End If
End If
Close #1
End Sub
Sub SaveShtsAsBook()
Dim Sheet As Worksheet, SheetName$, MyFilePath$, N&
MyFilePath$ = [Link] & "\" & _
Left([Link], Len([Link]) - 4)
With Application
.ScreenUpdating = False
.DisplayAlerts = False
On Error Resume Next '<< a folder exists
MkDir MyFilePath '<< create a folder
For N = 1 To [Link]
Sheets(N).Activate
SheetName = [Link]
[Link]
[Link] (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
Open MyFilePath & "\READ [Link]" For Output As #1
Print #1, "Thank you for trying out this product."
Print #1, "If it meets your requirements, visit"
Print #1, "[Link] to purchase"
Print #1, "the full (unrestricted) version..."
Close #1
End Sub
*****************************************************************
he code that will permanently delete the file after the date set-up in the back-end is
passed.
1 Private Sub Workbook_Open()
2
Dim exdate As Date
3
Dim i As Integer
4
5 'modify values for expiration date here !!!
6 anul = 2015 'year
7 luna = 11 'month
8 ziua = 1 'day
9
exdate = DateSerial(anul, luna, ziua)
10
11
If Date > exdate Then
12 MsgBox ("The application " & [Link] & " has expired !" & vbNewLine & vbN
13 & "Expiration set up date is: " & exdate & " :)" & vbNewLine & vbNewLine _
14 & "Contact Administrator to renew the version !"), vbCritical, [Link]
15
16 expired_file = [Link] & "\" & [Link]
17
On Error GoTo ErrorHandler
18 With Workbooks([Link])
19 If .Path <> "" Then
20
21 .Saved = True
22 .ChangeFileAccess xlReadOnly
23
24 Kill expired_file
25
'get the name of the addin if it is addin and unistall addin
26 If [Link] >= 12 Then
27 i = 5
28 Else: i = 4
29 End If
30
31 If Right([Link], i) = ".xlam" Or Right([Link], i) = ".xla" The
wbName = Left([Link], Len([Link]) - i)
32 'uninstall addin if it is installed
33 If AddIns(wbName).Installed Then
34 AddIns(wbName).Installed = False
35 End If
36 End If
37
.Close
38
39
40
41
42
End If
43
End With
44
45 Exit Sub
46
47 End If
48
49 'MsgBox ("You have " & exdate - Date & "Days left")
50 Exit Sub
51
ErrorHandler:
52
MsgBox "Fail to delete file.. "
53 Exit Sub
54
55 End Sub
56
57
58
59
! If the current date is greater than the date from the code, the user receives the below error
and the file is deleted forever 🙂
* Before using the above code please make sure that you create a backup of the original file
without the protection code and you set-up the “Expiration Date” parameters in future.
!!! Do not forget to protect your VBA code with a password. Otherwise, users will be able
to see and delete the code. To protect a VBA project, follow these steps.
–> This is a solution, but not a perfect one… A better solution would be to check the
computer of user and if that computer is not one provided by the company, the application
cannot be opened. You will also have an expiration date for the file in case there are users
that will “get the trick” and change their computer names 🙂
To get the computer name you can use this:
1 Dim CompName As String
2
3 'Get Computer Name
4
5 CompName = Environ$("computername")
6
MsgBox CompName
7
You can then check if the CompName follows the naming pattern of the computers from
your organization.
A third solution: you can ask the user to provide a key first time he opens your application.
If the provided key is equal to the key from your code, store it in a hidden sheet TRUE in a
column named “Key Activated”. Then check if “Key Activated” is TRUE, and if yes, the user can
open the file, if not, close the file.. You must combine this with the computer name. Every
time the file is opened, check the computer name, and if it is a new computer, ask again for
the key. If the user provides the correct key, store also that combination of computer name
and “Key Activated” TRUE.
Option Explicit
Public MyDate As Variant
Public Passwd As String
Private Sub WorkBook_Open()
Dim mbox As String
MyDate = #8/28/2019# ' Assign a date.
Passwd = "ABCD" 'Assign password
[Link] = False
Sheets("Sheet1").Visible = True
Sheets("Sheet2").Visible = xlVeryHidden
[Link] = True
If Date > MyDate Then
MsgBox "Oops! Test/Evaluation period of the utility has been expired." & vbCrLf & _
"Pls ask the concern person to get the updated utility.", vbCritical, "Outdated/Expired Version"
mbox = [Link]("Pls input the password/code to continue...", "Password")
If mbox <> Passwd Then
MsgBox "Incorrect Password" & vbCrLf & _
"Pls ask the concern person to get the correct password.", vbCritical, "Wrong password"
[Link]
With ThisWorkbook
.Save
.ChangeFileAccess Mode:=xlReadOnly
Kill .FullName
.Close SaveChanges:=False
End With
Else
Sheets("Sheet2").Visible = True
Sheets("Sheet1").Visible = False
End If
End IfOption Explicit
Public MyDate As Variant
Public Passwd As String
Private Sub WorkBook_Open()
Dim mbox As String
MyDate = #8/28/2019# ' Assign a date.
Passwd = "ABCD" 'Assign password
[Link] = False
Sheets("Sheet1").Visible = True
Sheets("Sheet2").Visible = xlVeryHidden
[Link] = True
If Date > MyDate Then
MsgBox "Oops! Test/Evaluation period of the utility has been expired." & vbCrLf & _
"Pls ask the concern person to get the updated utility.", vbCritical, "Outdated/Expired Version"
mbox = [Link]("Pls input the password/code to continue...", "Password")
If mbox <> Passwd Then
MsgBox "Incorrect Password" & vbCrLf & _
"Pls ask the concern person to get the correct password.", vbCritical, "Wrong password"
[Link]
With ThisWorkbook
.Save
.ChangeFileAccess Mode:=xlReadOnly
Kill .FullName
.Close SaveChanges:=False
End With
Else
Sheets("Sheet2").Visible = True
Sheets("Sheet1").Visible = False
End If
End IfOption Explicit
Public MyDate As Variant
Public Passwd As String
Private Sub WorkBook_Open()
Dim mbox As String
MyDate = #8/28/2019# ' Assign a date.
Passwd = "ABCD" 'Assign password
[Link] = False
Sheets("Sheet1").Visible = True
Sheets("Sheet2").Visible = xlVeryHidden
[Link] = True
If Date > MyDate Then
MsgBox "Oops! Test/Evaluation period of the utility has been expired." & vbCrLf & _
"Pls ask the concern person to get the updated utility.", vbCritical, "Outdated/Expired Version"
mbox = [Link]("Pls input the password/code to continue...", "Password")
If mbox <> Passwd Then
MsgBox "Incorrect Password" & vbCrLf & _
"Pls ask the concern person to get the correct password.", vbCritical, "Wrong password"
[Link]
With ThisWorkbook
.Save
.ChangeFileAccess Mode:=xlReadOnly
Kill .FullName
.Close SaveChanges:=False
End With
Else
Sheets("Sheet2").Visible = True
Sheets("Sheet1").Visible = False
End If
End If
Public MyDate As Variant
Public Passwd As String
Private Sub WorkBook_Open()
Dim mbox As String
MyDate = #8/28/2019# ' Assign a date.
Passwd = "ABCD" 'Assign password
[Link] = False
Sheets("Sheet1").Visible = True
Sheets("Sheet2").Visible = xlVeryHidden
[Link] = True
If Date > MyDate Then
MsgBox "Oops! Test/Evaluation period of the utility has been expired." & vbCrLf & _
"Pls ask the concern person to get the updated utility.", vbCritical, "Outdated/Expired Version"
mbox = [Link]("Pls input the password/code to continue...", "Password")
If mbox <> Passwd Then
MsgBox "Incorrect Password" & vbCrLf & _
"Pls ask the concern person to get the correct password.", vbCritical, "Wrong password"
[Link]
With ThisWorkbook
.Save
.ChangeFileAccess Mode:=xlReadOnly
Kill .FullName
.Close SaveChanges:=False
End With
Else
Sheets("Sheet2").Visible = True
Sheets("Sheet1").Visible = False
End If
End IfOption Explicit
Public MyDate As Variant
Public Passwd As String
Private Sub WorkBook_Open()
Dim mbox As String
MyDate = #8/28/2019# ' Assign a date.
Passwd = "ABCD" 'Assign password
[Link] = False
Sheets("Sheet1").Visible = True
Sheets("Sheet2").Visible = xlVeryHidden
[Link] = True
If Date > MyDate Then
MsgBox "Oops! Test/Evaluation period of the utility has been expired." & vbCrLf & _
"Pls ask the concern person to get the updated utility.", vbCritical, "Outdated/Expired Version"
mbox = [Link]("Pls input the password/code to continue...", "Password")
If mbox <> Passwd Then
MsgBox "Incorrect Password" & vbCrLf & _
"Pls ask the concern person to get the correct password.", vbCritical, "Wrong password"
[Link]
With ThisWorkbook
.Save
.ChangeFileAccess Mode:=xlReadOnly
Kill .FullName
.Close SaveChanges:=False
End With
Else
Sheets("Sheet2").Visible = True
Sheets("Sheet1").Visible = False
End If
End IfOption Explicit
Public MyDate As Variant
Public Passwd As String
Private Sub WorkBook_Open()
Dim mbox As String
MyDate = #8/28/2019# ' Assign a date.
Passwd = "ABCD" 'Assign password
[Link] = False
Sheets("Sheet1").Visible = True
Sheets("Sheet2").Visible = xlVeryHidden
[Link] = True
If Date > MyDate Then
MsgBox "Oops! Test/Evaluation period of the utility has been expired." & vbCrLf & _
"Pls ask the concern person to get the updated utility.", vbCritical, "Outdated/Expired Version"
mbox = [Link]("Pls input the password/code to continue...", "Password")
If mbox <> Passwd Then
MsgBox "Incorrect Password" & vbCrLf & _
"Pls ask the concern person to get the correct password.", vbCritical, "Wrong password"
[Link]
With ThisWorkbook
.Save
.ChangeFileAccess Mode:=xlReadOnly
Kill .FullName
.Close SaveChanges:=False
End With
Else
Sheets("Sheet2").Visible = True
Sheets("Sheet1").Visible = False
End If
End If
**********************************************************************************
**********************************************************************************
Private Sub Workbook_Open()
Dim StartTime#, CurrentTime#
Dim TrialPeriod, NewStartTime, NewTrialPeriod
Dim ContKey As String
Dim sh As Worksheet
Dim rStartTime As Range
Dim rTrialPeriod As Range
Dim rKeyList As Range
'********ADDED*********
' Dim UsedKey As String
Dim KeyList As String
Dim KeyOk As Boolean
KeyOk = True
'*********************
Set sh = Sheets("Log") 'This sheet is very hidden
Set rStartTime = [Link]("StartTime") '(Range A2 of Log sheet)
Set rTrialPeriod = [Link]("TrialPeriod") '(Range B2 of Log sheet)
Set rKeyList = [Link]("KeyList") '(Range C2 of Log sheet)
'*****************************************
'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
TrialPeriod = 15 '< 15 days trial
'If no start time exists then enter the start time and
'the trial period set above into hidden sheet and exit sub
If [Link] = "" Then
[Link] = Format(Now, "#0.#########0")
rTrialPeriod = TrialPeriod
MsgBox "Thank you for trying this software"
[Link]
Exit Sub
Else 'If start time does exist, get the start time and the trial period from the hidden sheet
StartTime = [Link]
TrialPeriod = [Link]
End If
CurrentTime = Format(Now, "#0.#########0")
'If not past trial perid then exit sub
If CurrentTime < StartTime + TrialPeriod Then
Exit Sub
End If
'If A1 <> Expired
If [A1] <> "Expired" Then
'Input box for option of entering a key
ContKey = InputBox("Sorry, your trial period has expired. If you " & _
"have a key, enter it now, otherwise your data will be extracted and " & _
"saved for you..." & vbNewLine & "This workbook will then be made unusable until you
purchase a key.")
'Check list of already used keys to see if key has been used before. If it has then set
'KeyOk to False (it's set to true at the beginning of this sub
Do Until [Link] = ""
If [Link] = ContKey Then KeyOk = False
Set rKeyList = [Link](1, 0)
Loop
Set rKeyList = [Link]("KeyList")
If KeyOk = False Then
MsgBox "Sorry, that is not a valid key. You can try again after you purchase a key"
' SaveShtsAsBook
[A1] = "Expired"
[Link]
[Link]
Exit Sub
End If
'*******************************
'If the key entered into input box does not match a pattern you pick then
'run SaveShtsAsBook and do whatever else you need to do to end your app
'The pattern in this code is the first 5 characters must be
'"w14rt" and the last 7 must be "trbft51" in upper or lower case
If UCase(Left(ContKey, 5)) <> "W14RT" Or UCase(Right(ContKey, 7)) <> "TRBFT51" Then
MsgBox "Sorry, that is not a valid key. You can try again after you purchase a key"
' SaveShtsAsBook
[A1] = "Expired"
[Link]
[Link]
Exit Sub
Else
'Else if the pattern of the key is ok then retrieve the the data from the middle of the key
'which will be some kind of hidden message to tell how much longer to continue
'the trial. Then open the log file back up and enter the new data
'I will use characters 6, 8, 9, 12, 13, 15, and 17 as the digits to retrieve
'for the trial period (the reason for so many is in case you have a lifetime
'key to give, just make the number really huge so it's like millions of days
'into the future, otherwise use leading zeros for the first however many digits
'you need to. You will pick what to put into those places when for the key that
'gets entered, and that will decide the new trial period. So those characters places
'that I mentioned above will be where you want to have digits that will decide the new
'trial period in the key that you give them. Nobody will know the pattern, or the
'place of the characters to retrieve
NewStartTime = Format(Now, "#0.#########0")
'Make NewTrialPeriod = to the number of days for the extended period
NewTrialPeriod = Val(Mid(ContKey, 6, 1) & Mid(ContKey, 8, 1) & Mid(ContKey, 9, 1) & _
Mid(ContKey, 12, 1) & Mid(ContKey, 13, 1) & Mid(ContKey, 15, 1) & Mid(ContKey, 17, 1))
'Enter the new start time and trial period, then exit sub
[Link] = NewStartTime
[Link] = NewTrialPeriod
'Add this key to the list of keys already used
[Link]("C" & [Link]).End(xlUp).Offset(1, 0).Value = ContKey
[A1].Value = ""
[Link]
Exit Sub
End If
End If
'If A1 already = "Expired" still offer a chance to enter a key which is almost a duplicate of
'above but with a different message and just quit application if no valid key is entered
If [A1] = "Expired" Then
ContKey = InputBox("Sorry, your trial period has expired. If you " & _
"have a key, enter it now, otherwise this application will end.")
'Check list of already used keys to see if key has been used before. If it has then set
'KeyOk to False (it's set to true at the beginning of this sub
Do Until [Link] = ""
If [Link] = ContKey Then KeyOk = False
Set rKeyList = [Link](1, 0)
Loop
Set rKeyList = [Link]("KeyList")
If KeyOk = False Then
MsgBox "Sorry, that is not a valid key. You can try again after you purchase a key"
[Link]
Exit Sub
End If
'If the key pattern is not ok then just bring up message and quit
If UCase(Left(ContKey, 5)) <> "W14RT" Or UCase(Right(ContKey, 7)) <> "TRBFT51" Then
MsgBox "Sorry, that is not a valid key. You can try again after you purchase a key"
[Link]
Exit Sub
Else
'key pattern was ok so get the characters just like from above
'and change the start time and trial period on the hidden sheet
NewStartTime = Format(Now, "#0.#########0")
'Make NewTrialPeriod = to the number of days for the extended period
NewTrialPeriod = Val(Mid(ContKey, 6, 1) & Mid(ContKey, 8, 1) & Mid(ContKey, 9, 1) & _
Mid(ContKey, 12, 1) & Mid(ContKey, 13, 1) & Mid(ContKey, 15, 1) & Mid(ContKey, 17, 1))
'Enter the new start time and trial period into the log file, then exit sub
rStartTime = NewStartTime
rTrialPeriod = NewTrialPeriod
'Add this key to the list of keys already used
[Link]("C" & [Link]).End(xlUp).Offset(1, 0).Value = ContKey
[A1].Value = ""
[Link]
Exit Sub
End If
End If
'Now at this point if a valid key is entered, then the trial period should be extended whatever
'lenght of time was decided from the digits that I mentioned above...
'so for example...if you were to send someone a key to extend the period 30 days, it would be a key
'something like this: W14RT0M00BH007390TRBFT51
'First 5 have to be w14rt, and last 7 have to be trbft51 (in upper or lower case, doesn't matter) to
'match the pattern for a key you would give someone
'The code retrieves digits 6, 8, 9, 12, 13, 15 and 17 to get the trial extension time
'6, 8, 9, 12, and 13 are zeros, 15 is a 3, and 17 is a zero to end up with 0000030
End Sub
--------------------*******************************************************
Sub Auto_Open()
Dim exdate As Date
exdate = "09/30/2015"
If Date > exdate Then
MsgBox ("You have reached end of your trial period")
[Link]
End If
MsgBox ("You have " & exdate - Date & "Days left")
End Sub
BA Code:
Option Explicit
Public MyDate As Variant
Public Passwd As String
Private Sub WorkBook_Open()
Dim mbox As String
MyDate = #8/28/2019# ' Assign a date.
Passwd = "ABCD" 'Assign password
[Link] = False
Sheets("Sheet1").Visible = True
Sheets("Sheet2").Visible = xlVeryHidden
[Link] = True
If Date > MyDate Then
MsgBox "Oops! Test/Evaluation period of the utility has been expired." & vbCrLf & _
"Pls ask the concern person to get the updated utility.", vbCritical, "Outdated/Expired Version"
mbox = [Link]("Pls input the password/code to continue...", "Password")
If mbox <> Passwd Then
MsgBox "Incorrect Password" & vbCrLf & _
"Pls ask the concern person to get the correct password.", vbCritical, "Wrong password"
[Link]
With ThisWorkbook
.Save
.ChangeFileAccess Mode:=xlReadOnly
Kill .FullName
.Close SaveChanges:=False
End With
Else
Sheets("Sheet2").Visible = True
Sheets("Sheet1").Visible = False
End If
End If
Option Explicit
'After and on July 1 this year, the code would not run past the first line because the current date
would be greater han the criteria date.
Code:
Sub t()
If Date >= #7/1/2019# Then Exit Sub
'Your regular code here
End Sub
'Date is current date
'The date with the pound symbols is the criteria date. The pound symbols make it date literal so it
will be the correct data type.
