Results 1 to 12 of 12
  1. #1
    Freddie81 is offline Competent Performer
    Windows 10 Access 2013 64bit
    Join Date
    Mar 2018
    Posts
    149

    Arrow Need help for code to limit database usage period

    Hi Guy, Im new to the whole Access scene and I made a database that allows gamers to record all their games from all off the years.



    Poblem is I need to allow them to test the application without allowing them to keep it permanently until they paid the subscription fee to th client. I was thinking of using a activation code whee they will have full access to it for 7 days and then either nee t enter the activation code to unlock it permanently or if not then the program stops working. I hav NO idea where to begin with the code :-Ony help would e appreciated

  2. #2
    ranman256's Avatar
    ranman256 is offline VIP
    Windows Vista Access 2010 32bit
    Join Date
    Apr 2014
    Location
    Kentucky
    Posts
    9,521
    you would need an install app: to put the database on their pc and run the InstallDemo() code to set the date limit
    the database would have to be an .accde so the user cannot get into the code.


    you may want to change the name of MYAPP to your app name:
    Private Const kAPP = "MYAPP"


    the expiration date is set in the registry under this app name.


    create a macro: autoexec
    in this RUNCODE: StartDemo()


    run demo will check the date from the internet ,then if expired, close the app.

    Code:
    Option Compare Database
    'Option Explicit
    
    
    Private Const kAPP = "MYAPP"
    Private Const kSECT = "Config"
    Private Const kKEY = "EDATE"
    
    
    Public Function getNetTime(Optional utc As Boolean) As String
    Dim vDate
    Dim SvrName(14), xPost, HttpAdd, NowTime, StartTime
    '//Get current time from internet time server
    '//by jimmyzs
    
    
    StartTime = Now
    '//internet time server list
    SvrName(1) = "time-nw.nist.gov"
    '//Microsoft, Redmond, Washington 131.107.1.10
    SvrName(2) = "time-a.nist.gov"
    '//NIST, Gaithersburg, Maryland  129.6.15.28
    SvrName(3) = "time-b.nist.gov"
    '//NIST, Gaithersburg, Maryland  129.6.15.29
    SvrName(4) = "time-a.timefreq.bldrdoc.gov"
    '//NIST, Boulder, Colorado  132.163.4.101
    SvrName(5) = "time-b.timefreq.bldrdoc.gov"
    '//NIST, Boulder, Colorado  132.163.4.102
    SvrName(6) = "time-c.timefreq.bldrdoc.gov"
    '//NIST, Boulder, Colorado  132.163.4.103
    SvrName(7) = "utcnist.colorado.edu"
    '//University of Colorado, Boulder  128.138.140.44
    SvrName(8) = "time.nist.gov"
    '//NCAR, Boulder, Colorado  192.43.244.18
    SvrName(9) = "nist1.datum.com"
    '//Datum, San Jose, California  66.243.43.21
    SvrName(10) = "nist1.dc.glassey.com"
    '//Abovenet, Virginia  216.200.93.8
    SvrName(11) = "nist1.ny.glassey.com"
    '//Abovenet, New York City  208.184.49.9
    SvrName(12) = "nist1.sj.glassey.com"
    '//Abovenet, San Jose, California  207.126.103.204
    SvrName(13) = "nist1.aol-ca.truetime.com"
    '//TrueTime, AOL facility, Sunnyvale, CA  207.200.81.113
    SvrName(14) = "nist1.aol-va.truetime.com"
    '//TrueTime, AOL facility, Virginia  205.188.185.33
    '//use xmlhttp object
     strComputer = "."
    Set objWMIService = GetObject("winmgmts:" _
        & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
     
    Set colTimeZone = objWMIService.ExecQuery("Select * from Win32_computersystem")
    For Each objTimeZone In colTimeZone
        Offset = objTimeZone.currenttimezone
    Next
    Set xPost = CreateObject("Microsoft.XMLHTTP")
        
      For i = 11 To 11
     'For i = 1 To 14
        
            HttpAdd = "Http://" & SvrName(i) & ":13": NowTime = ""
            frmsvr = SvrName(i)
            xPost.Open "Put", HttpAdd, False
            '//synchronize
            xPost.Send
          '//send requst to http server and receive response
          '  Delay 10
          '//set delay
            If xPost.ReadyState = 4 Then
                '//success or failed
                NowTime = Mid(xPost.responsetext, 8, 17)
                
                
                i = InStr(xPost.responsetext, ">Date:")
                vDate = Mid(xPost.responsetext, i + 18, 22)
                
                'getNetTime = vdate
                'Debug.Print vdate
                
                       '//return response
                '            If NowTime <> "" Then
                '                NowTime = Mid(NowTime, 7, 2) & Mid(NowTime, 3, 4) & Left(NowTime, 2) & Mid(NowTime, 9)
                '                NowTime = CDate(NowTime)
                '                If Not utc Then NowTime = CDate(NowTime) + Offset / 60 / 24
                '                gettime = NowTime
                '                Exit For
                '           Else
                '              xPost.abort
                '              NowTime = ""
                '          End If
        End If
        getNetTime = CDate(vDate) + Offset / 60 / 24
    Next
    '//internet connection problem
    If DateDiff("s", StartTime, Now) >= 30 And NowTime = "" Then
        gettime = "Please check your internet connection."
    End If
    'EndWhile
    Rem EndConnect
    xPost.abort
    Set xPost = Nothing
    End Function
    
    
    
    
    Public Sub InstallDemo()
    Dim vCurrDate, vEndDate
    
    
    On Error GoTo errInstall
    
    
    vCurrDate = Date    'we can use the users PC date to install
    'vCurrDate = getNetTime()
    vEndDate = GetSetting(kAPP, kSECT, kKEY)
    If Not IsDate(vEndDate) Then SaveSetting kAPP, kSECT, kKEY, vCurrDate
    Exit Sub
    
    
    errInstall:
    MsgBox Err.Description, , Err
    DoCmd.Quit acQuitSaveNone
    End Sub
    
    
    Public Function IsDemoExpired()
    Dim vCurrDate As Date, vEndDate As Date
    
    
    vCurrDate = getNetDate()     'get date from internet, not PC (users could backdate the pc)
    If Not IsDate(vCurrDate) Then
       MsgBox "Date could not be read", , "Error"
       Exit Function
    End If
    
    
    vEndDate = GetSetting(kAPP, kSECT, kKEY)
    IsDemoExpired = vCurrDate > vEndDate
    End Function
    
    
    Private Function getNetDate()
    Dim vDT
    vDT = getNetTime()
    If IsDate(vDT) Then getNetDate = Format(vDT, "mm/dd/yyyy")
    End Function
    
    
    Public Function StartDemo()
    If IsDemoExpired() Then
       MsgBox "Demo has expired"
       DoCmd.Quit
    Else
      DoCmd.OpenForm "frmMainMenu"
    End If
    End Function

  3. #3
    Freddie81 is offline Competent Performer
    Windows 10 Access 2013 64bit
    Join Date
    Mar 2018
    Posts
    149
    Hi ranman256

    Thank you for the quick reply...I really do appreciate this

    I downloaded innosetup as the install app...hope that will work?
    So this code will set the install date in the registry, then check if it has expired evertime the prgram is oopened? will it ask the user to enter the serial number whe expired or just close the app? If so, then how would I get it to work normally again if they cant enter the code or serial number?

  4. #4
    ranman256's Avatar
    ranman256 is offline VIP
    Windows Vista Access 2010 32bit
    Join Date
    Apr 2014
    Location
    Kentucky
    Posts
    9,521
    i didnt write that code. gimme a sec.
    you must hardcode a serial # for each individual.... kMySER = "123456"
    KEEP TRACK of who gets what serial.


    Code:
    Option Compare Database
    'Option Explicit
    
    
    Private Const kMySER = "123456"
    Private Const kAPP = "MYAPP"
    Private Const kSECT = "Config"
    Private Const kXDAT = "EDATE"
    Private Const kSER = "Serial"
    Private Const kTMP = "Temp"
    
    
    Public Function getNetTime(Optional utc As Boolean) As String
    Dim vDate
    Dim SvrName(14), xPost, HttpAdd, NowTime, StartTime
    '//Get current time from internet time server
    '//by jimmyzs
    
    
    StartTime = Now
    '//internet time server list
    SvrName(1) = "time-nw.nist.gov"
    '//Microsoft, Redmond, Washington 131.107.1.10
    SvrName(2) = "time-a.nist.gov"
    '//NIST, Gaithersburg, Maryland  129.6.15.28
    SvrName(3) = "time-b.nist.gov"
    '//NIST, Gaithersburg, Maryland  129.6.15.29
    SvrName(4) = "time-a.timefreq.bldrdoc.gov"
    '//NIST, Boulder, Colorado  132.163.4.101
    SvrName(5) = "time-b.timefreq.bldrdoc.gov"
    '//NIST, Boulder, Colorado  132.163.4.102
    SvrName(6) = "time-c.timefreq.bldrdoc.gov"
    '//NIST, Boulder, Colorado  132.163.4.103
    SvrName(7) = "utcnist.colorado.edu"
    '//University of Colorado, Boulder  128.138.140.44
    SvrName(8) = "time.nist.gov"
    '//NCAR, Boulder, Colorado  192.43.244.18
    SvrName(9) = "nist1.datum.com"
    '//Datum, San Jose, California  66.243.43.21
    SvrName(10) = "nist1.dc.glassey.com"
    '//Abovenet, Virginia  216.200.93.8
    SvrName(11) = "nist1.ny.glassey.com"
    '//Abovenet, New York City  208.184.49.9
    SvrName(12) = "nist1.sj.glassey.com"
    '//Abovenet, San Jose, California  207.126.103.204
    SvrName(13) = "nist1.aol-ca.truetime.com"
    '//TrueTime, AOL facility, Sunnyvale, CA  207.200.81.113
    SvrName(14) = "nist1.aol-va.truetime.com"
    '//TrueTime, AOL facility, Virginia  205.188.185.33
    '//use xmlhttp object
     strComputer = "."
    Set objWMIService = GetObject("winmgmts:" _
        & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
     
    Set colTimeZone = objWMIService.ExecQuery("Select * from Win32_computersystem")
    For Each objTimeZone In colTimeZone
        Offset = objTimeZone.currenttimezone
    Next
    Set xPost = CreateObject("Microsoft.XMLHTTP")
        
      For i = 11 To 11
     'For i = 1 To 14
        
            HttpAdd = "Http://" & SvrName(i) & ":13": NowTime = ""
            frmsvr = SvrName(i)
            xPost.Open "Put", HttpAdd, False
            '//synchronize
            xPost.Send
          '//send requst to http server and receive response
          '  Delay 10
          '//set delay
            If xPost.ReadyState = 4 Then
                '//success or failed
                NowTime = Mid(xPost.responsetext, 8, 17)
                
                
                i = InStr(xPost.responsetext, ">Date:")
                vDate = Mid(xPost.responsetext, i + 18, 22)
                
                'getNetTime = vdate
                'Debug.Print vdate
                
                       '//return response
                '            If NowTime <> "" Then
                '                NowTime = Mid(NowTime, 7, 2) & Mid(NowTime, 3, 4) & Left(NowTime, 2) & Mid(NowTime, 9)
                '                NowTime = CDate(NowTime)
                '                If Not utc Then NowTime = CDate(NowTime) + Offset / 60 / 24
                '                gettime = NowTime
                '                Exit For
                '           Else
                '              xPost.abort
                '              NowTime = ""
                '          End If
        End If
        getNetTime = CDate(vDate) + Offset / 60 / 24
    Next
    '//internet connection problem
    If DateDiff("s", StartTime, Now) >= 30 And NowTime = "" Then
        gettime = "Please check your internet connection."
    End If
    'EndWhile
    Rem EndConnect
    xPost.abort
    Set xPost = Nothing
    End Function
    
    
    
    
    Public Sub InstallDemo()
    Dim vCurrDate, vEndDate
    
    
    On Error GoTo errInstall
    
    
    vCurrDate = Date    'we can use the users PC date to install
    'vCurrDate = getNetTime()
    vEndDate = GetSetting(kAPP, kSECT, kXDAT)
    If Not IsDate(vEndDate) Then
       SaveSetting kAPP, kSECT, kXDAT, vCurrDate
       SaveSetting kAPP, kSECT, kTMP, kMySER    'INSTALL THE TEMP SERIAL# to match when user buys it.
    End If
    Exit Sub
    
    
    errInstall:
    MsgBox Err.Description, , Err
    DoCmd.Quit acQuitSaveNone
    End Sub
    
    
    Public Function IsDemoExpired()
    Dim vCurrDate As Date, vEndDate As Date
    
    
    vCurrDate = getNetDate()     'get date from internet, not PC (users could backdate the pc)
    If Not IsDate(vCurrDate) Then
       MsgBox "Date could not be read", , "Error"
       Exit Function
    End If
    
    
    vEndDate = GetSetting(kAPP, kSECT, kXDAT)
    IsDemoExpired = vCurrDate > vEndDate
    End Function
    
    
    Private Function getNetDate()
    Dim vDT
    vDT = getNetTime()
    If IsDate(vDT) Then getNetDate = Format(vDT, "mm/dd/yyyy")
    End Function
    
    
    Public Function StartDemo()
    If IsDemoExpired() And Not IsValidSerial() Then
       MsgBox "Demo has expired"
       DoCmd.Quit
    Else
      DoCmd.OpenForm "frmMainMenu"
    End If
    End Function
    
    
    
    
    Public Function IsValidSerial() As Boolean
    Dim vSer, vTmp
    vSer = GetSetting(kAPP, kSECT, kMySER)
    vTmp = GetSetting(kAPP, kSECT, kTMP)
    IsValidSerial = UCase(vSer) = UCase(vTmp)
    End Function
    
    
    Public Sub InstallSerial()
    Dim vSerTmp, vRet
    
    
    vRet = InputBox("Enter Serial#", "Install serial#")
    If vRet = "" Then
       DoCmd.Quit
    Else
       vSerTmp = GetSetting(kAPP, kSECT, kTMP)
       If UCase(vSerTmp) = UCase(vRet) Then
           SaveSetting kAPP, kSECT, kSER, kMySER    'save the full valid serial#
       Else
           MsgBox "Invalid Serial#", vbCritical, vRet
           DoCmd.Quit
       End If
    End If
    End Sub

  5. #5
    Freddie81 is offline Competent Performer
    Windows 10 Access 2013 64bit
    Join Date
    Mar 2018
    Posts
    149
    Thank you

    I assume this code goes first before any other sub or function from combo boxes etc ?

  6. #6
    ranman256's Avatar
    ranman256 is offline VIP
    Windows Vista Access 2010 32bit
    Join Date
    Apr 2014
    Location
    Kentucky
    Posts
    9,521
    the autoexec macro runs upon opening and then Checks on serial/demo.

    install would have to be a separate app to put in the key items.
    a form would be needed for user to enter a valid serial.

  7. #7
    isladogs's Avatar
    isladogs is offline MVP / VIP
    Windows 10 Access 2010 32bit
    Join Date
    Jan 2014
    Location
    Somerset, UK
    Posts
    5,954
    This code will only do a very small part of what you want.

    How are you going to prevent users uninstalling and reinstalling repeatedly at the end of the evaluation period.
    Similarly, how will you stop them just installing another evaluation copy on a different computer?

    If they purchase a licence, how will you limit that to a specific computer?

    I'm not trying to be negative but to point out that this is a complex task.
    I've been using Access for almost 20 years and recently did something similar.
    It took several days coding to cover all possible issues to my satisfaction.
    No Access app will ever be totally secure and making it as secure as possible in the way you want is not an easy task.

    You might find this thread I started at another forum worth reading
    https://www.access-programmers.co.uk...d.php?t=297691

    I agree with ranman about using a professional installer application as this can handle SOME of the issues
    Colin, Access MVP, Website, email
    The more I learn, the more I know I don't know. When I don't know, I keep quiet!
    If I don't know that I don't know, I don't know whether to answer

  8. #8
    Freddie81 is offline Competent Performer
    Windows 10 Access 2013 64bit
    Join Date
    Mar 2018
    Posts
    149
    Thank you guys!

    Thanks Ridders52, I actually didnt think about that on. Ill folowyour lik and see if that helps. Ive actually managed to get the code for a licenselck file but I cant seem to get it to create the accd file required.
    This allows me to issue a trial license file and when they subscribe they get mailed a ful version license file so even if they uistalland reinstall it wont help as it is hardcded.

  9. #9
    Freddie81 is offline Competent Performer
    Windows 10 Access 2013 64bit
    Join Date
    Mar 2018
    Posts
    149
    Would you guys midnd taking a look at the Lockfilemaker file and se why its not creating the accde file for lockfile ? The download link is https://drive.google.com/open?id=1ME...u9c0rjKw3bW5gv

  10. #10
    isladogs's Avatar
    isladogs is offline MVP / VIP
    Windows 10 Access 2010 32bit
    Join Date
    Jan 2014
    Location
    Somerset, UK
    Posts
    5,954
    Suggest you contact the author of the utility as he/she will know how the code is meant to work
    Colin, Access MVP, Website, email
    The more I learn, the more I know I don't know. When I don't know, I keep quiet!
    If I don't know that I don't know, I don't know whether to answer

  11. #11
    Freddie81 is offline Competent Performer
    Windows 10 Access 2013 64bit
    Join Date
    Mar 2018
    Posts
    149
    I traced each line step by step and noticed it actually creates the file needed but or some reason doesnt save it as accde and then the program deletes it as an error. . I think if I can put my own code in to sav the lockfile.accdb to lockfile.accde then it will work. Ive sent him an mail last night so Im waiting patiently.

  12. #12
    isladogs's Avatar
    isladogs is offline MVP / VIP
    Windows 10 Access 2010 32bit
    Join Date
    Jan 2014
    Location
    Somerset, UK
    Posts
    5,954
    Best of luck - As i don't know what the utility is meant to do there is no point trying to guess
    However if you are talking about the lock file created when you open an ACCDB or ACCDE file, that is always an LACCDB file
    Colin, Access MVP, Website, email
    The more I learn, the more I know I don't know. When I don't know, I keep quiet!
    If I don't know that I don't know, I don't know whether to answer

Please reply to this thread with any new information or opinions.

Similar Threads

  1. Limit Data that Users see in Database
    By katkth7533 in forum Access
    Replies: 6
    Last Post: 02-11-2015, 08:09 AM
  2. Replies: 3
    Last Post: 03-08-2014, 06:01 PM
  3. Database Usage Counter in Main Form
    By rkalapura in forum Forms
    Replies: 5
    Last Post: 04-15-2012, 09:02 PM
  4. Set Database to Expire in time period
    By robsworld78 in forum Access
    Replies: 12
    Last Post: 06-07-2011, 06:54 AM
  5. Replies: 1
    Last Post: 10-22-2010, 01:29 PM

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  
Other Forums: Microsoft Office Forums