请问如何获得另外一台局域网上的计算机的当前时间！

Question

请问如何时时获得另外一台局域网上的计算机的当前时间！

Answer 1

1. API 方法This method uses NetRemoteTOD API function. Note: this function works on Win NT platform only. Code:Option Explicit Private Declare Function NetRemoteTOD Lib "NETAPI32.DLL" (ByVal server As String, buffer As Any) As Long Private Declare Function NetApiBufferFree Lib "NETAPI32.DLL" (ByVal buffer As Long) As Long Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long) Private Type TIME_OF_DAY 
    t_elapsedt As Long 
    t_msecs As Long 
    t_hours As Long 
    t_mins As Long 
    t_secs As Long 
    t_hunds As Long 
    t_timezone As Long 
    t_tinterval As Long 
    t_day As Long 
    t_month As Long 
    t_year As Long 
    t_weekday As Long 
End Type Public Function GetServerDateAPI(ByVal sServer As String) As Date 
    Dim t As TIME_OF_DAY 
    Dim tPtr As Long, res As Long 
    Dim szServer As String, days As Date 
    On Error Resume Next 
    If Left$(sServer, 2) <> "\\" Then sServer = "\\" & sServer 
    szServer = StrConv("\\Your Server!", vbUnicode) 'Convert the server name to unicode 
    res = NetRemoteTOD(szServer, tPtr) 'You could also pass vbNullString for the server name 
    If Err Then Exit Function 
    If res = 0 Then 
        CopyMemory t, ByVal tPtr, Len(t) 'Copy the pointer returned to a TIME_OF_DAY structure 
        days = DateSerial(70, 1, 1) + (t.t_elapsedt / 60 / 60 / 24) 'Convert the elapsed time since 1/1/70 to a date 
        days = days - (t.t_timezone / 60 / 24) 'Adjust for TimeZone differences 
        NetApiBufferFree (tPtr) 'Free the memory at the pointer 
        GetServerDateAPI = days 
    Else 
' MsgBox "Error occurred call NetRemoteTOD: " & res, vbOKOnly, "NetRemoteTOD" 
        'Error 53: cannot find server 
        Err.Number = 53 
    End If 
End Function

Answer 2

2. 写方件你要有写其他机子的权限Code:Public Function GetServerDateTrick(ByVal sServer As String) As Date 
    Dim sTempFile As String 
    If Left$(sServer, 2) <> "\\" Then sServer = "\\" & sServer 
    If Right$(sServer, 1) <> "\" Then sServer = sServer & "\" 
    sTempFile = sServer & "c\time.tmp" 
    On Error Resume Next 
    Open sTempFile For Binary As #1 
    Close #1 
    GetServerDateTrick = FileDateTime(sTempFile) 
    If Err Then GetServerDateTrick = 0 
    Kill sTempFile 
End Function
3. 用Net Time命令You also can use net.exe program which you can find at your windows directory. Here is small workaround how to call it from VB: Code:Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Public Function GetServerDateShell(ByVal sServer As String) As Date 
   If Left$(sServer, 2) <> "\\" Then sServer = "\\" & sServer 
   Dim nFile As Integer, t As Long 
   Dim sBatFile As String, sTextFile As String, sTemp As String 
   sBatFile = App.Path & "\nettime.bat" 
   sTextFile = App.Path & "\nettime.txt" 
   nFile = FreeFile 
   Open sBatFile For Output As #nFile 
        Print #nFile, "net time " & sServer & " > " & App.Path & "\nettime.txt" 
   Close #nFile 
   On Error Resume Next 
   Shell sBatFile, vbHide 
   If Err Then Exit Function 
   While Dir(sTextFile) = "" 'waiting file creation 
   Wend 
   Sleep 1000 ' wait while system write to file 
   Open sTextFile For Input As #nFile 
         Line Input #nFile, sTemp 
   Close #nFile 
   GetServerDateShell = CDate(Mid(sTemp, InStr(1, sTemp, ":") + 2)) 
   Kill sBatFile 
   Kill sTextFile 
End Function

Answer 3

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 TypePrivate 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 TypePrivate Declare Function GetTimeZoneInformation Lib "kernel32" (lpTimeZoneInformation As TIME_ZONE_INFORMATION) As LongPrivate 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("\\机器名称")
    MsgBox d
End Sub