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