Expires after certain date (1 Viewer)

Atholl

New member
Joined
Aug 29, 2005
Messages
7
Hi All,

I found the code below by Wayne Gillespie on an old Google Groups thread:
http://groups.google.co.uk/group/comp.databases.ms-access/browse_thread/thread/34319d3f2d22c6b/09ef0085c0517803?lnk=st&q=access+database+expire+system+date&rnum=2&hl=en#09ef0085c0517803

The code doesn't allow the db to be opened after 30 days, and also detects whether the user has changed the system date to get it to work after expiry. The only problem is that once expired, if you set the system date to somewhere between the install date and the expiry date, then the database will open!


Can anyone fix this loophole in the code?

Atholl

'==========Code Starts =================
Function CreateInstallProperties()
Dim MyDb As Database
Dim prpMyProp As Property
Dim dtPropDate As Date

On Error GoTo CreateInstallProperties_Err

dtPropDate = Date
Set MyDb = CurrentDb

'creates an InstallDate property defaulted to current date
Set prpMyProp = MyDb.CreateProperty("InstallDate", dbDate, dtPropDate)
MyDb.Properties.Append prpMyProp

'creates a LastOpened property defaulted to current date
Set prpMyProp = MyDb.CreateProperty("LastOpened", dbDate, dtPropDate)
MyDb.Properties.Append prpMyProp

'creates an IntallFlag property defaulted to false
Set prpMyProp = MyDb.CreateProperty("InstallFlag", dbBoolean, 0)
MyDb.Properties.Append prpMyProp

Set prpMyProp = Nothing

Exit Function

CreateInstallProperties_Err:
Debug.Print Err, Err.Description
Resume Next

End Function

Function CreateInstallFlagProperty()
Dim MyDb As Database
Dim prpMyProp As Property

On Error GoTo CreateInstallFlagProperty_Err

Set MyDb = CurrentDb

'creates an IntallFlag property defaulted to false
Set prpMyProp = MyDb.CreateProperty("InstallFlag", dbBoolean, 0)
MyDb.Properties.Append prpMyProp

Set prpMyProp = Nothing
Set MyDb = Nothing

Exit Function

CreateInstallFlagProperty_Err:
Debug.Print Err, Err.Description
Resume Next

End Function

Function DeleteNewProperties()
'used to delete the custom properties during
'development and testing

On Error Resume Next

CurrentDb.Properties.Delete "InstallDate"
CurrentDb.Properties.Delete "LastOpened"

End Function

Function ReadInstallDate()
'read InstallDate property
Dim MyDb As Database

On Error GoTo ReadInstall_Err

Set MyDb = CurrentDb
ReadInstallDate = MyDb.Properties![InstallDate]
Set MyDb = Nothing

ReadInstall_Exit:
Exit Function

ReadInstall_Err:
Beep
MsgBox "The property has not yet been created.", vbInformation +
vbOKOnly, "Well that didn't work"
Resume ReadInstall_Exit

End Function

Function SetLastOpenDate()
'sets the LastOpened custom property
'to current date

Dim MyDb As Database
Dim dtLastOpened As Date

dtLastOpened = Date

Set MyDb = CurrentDb
MyDb.Properties![LastOpened] = dtLastOpened
Set MyDb = Nothing

End Function

Function ReadLastOpenDate() As Date
'read LastOpenDate property
Dim MyDb As Database

On Error GoTo ReadLastOpen_Err

Set MyDb = CurrentDb
ReadLastOpenDate = MyDb.Properties![LastOpened]
Set MyDb = Nothing

ReadLastOpen_Exit:
Exit Function

ReadLastOpen_Err:
Beep
MsgBox "The property has not yet been created.", vbInformation +
vbOKOnly, "Well that didn't work"
Resume ReadLastOpen_Exit

End Function

Function SetInstallFlag()
'sets the InstallFlag custom property to True
'this initiates the demo lock
Dim MyDb As Database

On Error Resume Next

Set MyDb = CurrentDb
MyDb.Properties![InstallFlag] = True
Set MyDb = Nothing

End Function

Function ReadInstallFlag()
'read InstallFlag property
Dim MyDb As Database

On Error GoTo ReadInstallFlag_Err

Set MyDb = CurrentDb
ReadInstallFlag = MyDb.Properties![InstallFlag]
Set MyDb = Nothing

ReadInstallFlag_Exit:
Exit Function

ReadInstallFlag_Err:
Debug.Print Err, Err.Description

Beep
MsgBox "The property has not yet been created.", vbInformation +
vbOKOnly, "Well that didn't work"
Resume ReadInstallFlag_Exit

End Function

Function SetDemoLock()
'run to reset properties before deployment

DeleteNewProperties
SetInstallFlag

End Function

Function InitiateDemoLock() As Boolean
'runs from OnOpen Event of startup form
'checks InstallFlag property and if True
'creates and defaults Install properties to current date
Dim msgtxt As String, msgtit As String

If ReadInstallFlag() = True Then
'runs once only
'will exit through error handler if
'properties exist
CreateInstallProperties
'update LastOpen property
SetLastOpenDate

If (ReadLastOpenDate - ReadInstallDate) > 30 Then
'Allow 30 day trial
msgtxt = "Your 30 day trial period has expired." & vbCrLf
msgtxt = msgtxt & "Send me money!!"
msgtit = "Times Up"

Beep
MsgBox msgtxt, vbCritical + vbOKOnly, msgtit
'throw them out
InitiateDemoLock = True
ElseIf ReadLastOpenDate < ReadInstallDate Then
'check if system date has been changed
msgtxt = "Did you really think I was that stupid?" & vbCrLf
msgtxt = msgtxt & "Changing your system date won't work!"
msgtit = "Ha Ha Cant fool me"

Beep
MsgBox msgtxt, vbCritical + vbOKOnly, msgtit
'throw them out
InitiateDemoLock = True
Else
'open your app as usual
InitiateDemoLock = False
End If
Else
DoCmd.OpenForm "MyForm"
End If

End Function

'============= CODE ENDS =================
 

Summerwind

Registered User
Joined
Aug 25, 2005
Messages
91
Thanks for posting the code. I have been looking for something similar for I while.

As I haven't had time to study the code yet, I don't have an answer for you and there is no guarantee that I ever will, but I will definitely try.
 

JohnN2006

Registered User
Joined
Feb 17, 2006
Messages
16
Hi,

I have been looking at the same sort of thing as well.

As my VB programing isnt that advanced I have manged to achieve the same effect using forms and simple vb code.

I have enclosed an example.

The first thing to set up is the Expiry Date within the Expire table, the Expiry Status should be set to 0 (zero)

Each time the databse is opened the end user can see the amount of days left, as soon as this hits zero the Expiry Status is changed to 1.

Anyone who now tries to open the file will get a message saying that the free period has ended.

If you click on the Cancel button you will be prompted for an Administrator password (currently set to "admin").

It doesnt matter if the expiry date is over a weekend or a bank holiday.

I am currently using this in 3 bespoke databases I have written and have also included the code to set the AllowByPassKey to false so that there are no "back-doors" into the application.

Hope this is of some use.

John.

As someone has said on here before - "It might be basic but it works !"
 

Attachments

ghudson

Registered User
Joined
Jun 8, 2002
Messages
6,199
How do you prevent the user from connecting [linking] to your db and changing the expire date [or any table data]?

How do you prevent the user from importing the objects [tables, forms, etc.] from your db into another db?
 

Atholl

New member
Joined
Aug 29, 2005
Messages
7
Thanks for the example, JohnN, I'll have a look.

GHudson: I have a bits of code which hide the tables and disables the bypass key. I'll also convert to an .mde file. I'm not sure about the importing issue, have you any ideas? I realise that nothing's going to be 100% secure, but you can have an array of barriers to put off people from getting into the db.

Atholl
 

JohnN2006

Registered User
Joined
Feb 17, 2006
Messages
16
ghudson - again a simple answer from me, if you hide all of the objects from their properties window then they cannot be imported or linked to.

I would recommend setting the properties using vba on the opening screen and by using the AllowByPassKey property the end user should not have access to be able to amend anything.

John.
 

Atholl

New member
Joined
Aug 29, 2005
Messages
7
I also found the 'Updated Have Database Expire After 30 Days Of First Being Opened' db from here:

http://members.shaw.ca/glenk/access2000.html

I'm testing it and it appears to work (so far). It logs the period of db use to a table on first startup and also detects whether system date has been altered.

If anyone can find a loophole with this, then post it here!

Atholl
 

Attachments

Atholl

New member
Joined
Aug 29, 2005
Messages
7
I've tested this out and it too has the loophole that if you change the date to somewhere between the inception and expiry dates (as long as the db hasn't already expired), you can start the db no problem.

The 'rs.Movelast' command selects the last record in the table I guess, so if there is a command (which I don't think there is) to select the last 'rs.Fields("FlagDate")' which is checked/positive, then this line might work:

rs.MoveLast
If rs.Fields("FlagDate") = True And Date < rs.Fields("MeDate") Then
MsgBox "This Database has expired. Please contact vendor to purchase.", vbOKOnly, "Serious Warning"
DoCmd.Quit
End If
 
Last edited:

Summerwind

Registered User
Joined
Aug 25, 2005
Messages
91
Hi All

A useful thread this. I have been kicking around various methods based on suggestions in the thread and have come up with a solution that I'm happy with.

My only problem now is: What is to stop the user simply re-installing the demo? I'm fairly sure there is an answer to this using the Registry?? Any suggestions?
 

darksniper

Registered User
Joined
Sep 4, 2005
Messages
108
where do i put the code above, cause I inserted it int modules-> Global Code, and it doesnt do anything
 

GoAccess

New member
Joined
Mar 8, 2018
Messages
3
I've tested this out and it too has the loophole that if you change the date to somewhere between the inception and expiry dates (as long as the db hasn't already expired), you can start the db no problem.

The 'rs.Movelast' command selects the last record in the table I guess, so if there is a command (which I don't think there is) to select the last 'rs.Fields("FlagDate")' which is checked/positive, then this line might work:

rs.MoveLast
If rs.Fields("FlagDate") = True And Date < rs.Fields("MeDate") Then
MsgBox "This Database has expired. Please contact vendor to purchase.", vbOKOnly, "Serious Warning"
DoCmd.Quit
End If
---------------------------------------------------------------------------------
Very Excellent this work, but i want ask question : How do I open this file? if the customer want buy the program.
thank you for help.
 

Users Who Are Viewing This Thread (Users: 0, Guests: 1)

Top Bottom