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