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
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
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
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
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
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