Atholl
New member
- Local time
- Today, 05:36
- 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/co...ire+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 =================
I found the code below by Wayne Gillespie on an old Google Groups thread:
http://groups.google.co.uk/group/co...ire+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 =================