程序语言] Microsoft Visual Basic 4.0,5.0,6.0
[运行平台] WINDOWS
[源码来源] http://codeguru.developer.com/vb/articles/1915.shtml
[功能描述]
该程序正常执行后，将返回日期和时间值。而如果NetRemoteTOD API调用失败，则显示出错信息。
它将包含所有的时区信息。把下列代码加入到标准的BAS模块中。
option Explicit
'
'
private Declare Function NetRemoteTOD Lib "Netapi32.dll" ( _
tServer as Any, pBuffer as Long) as Long
'
private Type SYSTEMTIME
wYear as Integer
wMonth as Integer
wDayOfWeek as Integer
wDay as Integer
wHour as Integer
wMinute as Integer
wSecond as Integer
wMilliseconds as Integer
End Type
'
private Type TIME_ZONE_INFORMATION
Bias as Long
StandardName(32) as Integer
StandardDate as SYSTEMTIME
StandardBias as Long
DaylightName(32) as Integer
DaylightDate as SYSTEMTIME
DaylightBias as Long
End Type
'
private Declare Function GetTimeZoneInformation Lib "kernel32" (lpTimeZoneInformation as TIME_ZONE_INFORMATION) as Long
'
private Declare Function NetApiBufferFree Lib "Netapi32.dll" (byval lpBuffer as Long) as Long
'
private Type TIME_OF_DAY_INFO
tod_elapsedt as Long
tod_msecs as Long
tod_hours as Long
tod_mins as Long
tod_secs as Long
tod_hunds as Long
tod_timezone as Long
tod_tinterval as Long
tod_day as Long
tod_month as Long
tod_year as Long
tod_weekday as Long
End Type
'
private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination as Any, Source as Any, byval Length as Long)
'
'
public Function getRemoteTOD(byval strServer as string) as date
'
Dim result as date
Dim lRet as Long
Dim tod as TIME_OF_DAY_INFO
Dim lpbuff as Long
Dim tServer() as Byte
'
tServer = strServer & vbNullChar
lRet = NetRemoteTOD(tServer(0), lpbuff)
'
If lRet = 0 then
CopyMemory tod, byval lpbuff, len(tod)
NetApiBufferFree lpbuff
result = DateSerial(tod.tod_year, tod.tod_month, tod.tod_day) + _
TimeSerial(tod.tod_hours, tod.tod_mins - tod.tod_timezone, tod.tod_secs)
getRemoteTOD = result
else
Err.Raise Number:=vbObjectError + 1001, _
Description:="cannot get remote TOD"
End If
'
End Function
要运行该程序，通过如下方式调用。
private Sub Command1_Click()
Dim d as date
'
d = GetRemoteTOD("your NT server name goes here")
MsgBox d
End Sub
