[程序语言] 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