Получаем время с удалённого NT Сервера

Автор: Lothar Haensler

Здесь представлен небольшой пример, возвращающий VB Date. Данный код возвращает
всю информацию о часовом поясе.

Поместите следующий код в стандартный модуль 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("здесь нужно задать имя NT сервера")
    MsgBox d
End Sub
'
'
'

Скачать BAS модуль