Function Date_Check()
'* 日期较对 '因使用普通用户,不能操作系统目录,只能存放在应用目录
Dim SaveNow As Variant
Dim ReadNow
Dim Msg As Variant
Dim DateErr As Boolean
On Error GoTo ErrorHandle
'取系统目录
Dim Ans
Ans = SystemDir
strWinPath = Ans(0)
strSystemDir = Ans(1)
'* 读取储存的日期/时间
Open App.Path & "/DATE.DAT" For Input As #1
Input #1, ReadNow
SaveNow = CDate(ReadNow)
Close #1
'储存时间比当前时间大时错误发生。
If SaveNow > Now Then DateErr = True Else DateErr = False
If Not DateErr Then
'未发现错误,重新写入当前时期/时间。
Open App.Path & "/DATE.DAT" For Output As #1
Write #1, Now
Close #1
GoTo PROC_EXIT
Else
MsgBox "系统日期时间不正确,请重新设定系统日期时间 !!! ", vbCritical, "严重错误"
End
End If
PROC_EXIT:
Exit Function
ErrorHandle:
If err.Number = 53 Then
'首次运行程序,直接写入当前日期/时间
Open App.Path & "/DATE.DAT" For Output As #1
Write #1, Now
Close #1
Else
Call ShowError("Public", "Date_Check", err.Number, err.Description, "Y")
End If
End Function
Function SystemDir() As Variant
' WinPath 为 Windows 的所在目录, SysPath为 System 所在目录
'调用示例:
'dim Ans
'Ans=Systemdir
'Ans(0)=WinPath ,Ans(1)=SysPath
On Error GoTo ErrorHandle
Dim s As String * 80, Length As Long
Dim WinPath As String, SysPath As String
Length = GetWindowsDirectory(s, Len(s))
WinPath = Left(s, Length)
Length = GetSystemDirectory(s, Len(s))
SysPath = Left(s, Length)
SystemDir = Array(WinPath, SysPath) '返回两个值
Exit Function
ErrorHandle:
Call ShowError("Public", "SystemDir", err.Number, err.Description, "Y")
End Function