不通过数据库，怎样得到与自己连通的服务器的当前时间和日期

[hzhxxx]

不通过数据库，怎样得到与自己连通的服务器的当前时间和日期,最好不要使用 VB 专有的控件， 最好是使用 WIN32 API 得到

[athere_08]

不是服务器的有个端口可以吗？

[yclyz]

不会，学习！！！！

[hzhxxx]

Port is 13,How to send back date?

[no_com]

'===============取服务器时间======================
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim cm As New ADODB.Command
cn.ConnectionString = "Provider=SQLOLEDB.1;Persist Security Info=False;User ID=zqh1;Initial Catalog=clgl;Data Source=" & readstart
cn.Open
rs.CursorLocation = adUseClient
rs.Open "select getdate()", cn, adOpenDynamic, adLockBatchOptimistic
msgbox rs.fields(0)
rs.close
cn.close
set cn=nothing

[hzhxxx]

不通过数据库!!!!!!!!!!!!!!!!!

[junwhj]

取得服务器时间：
net time \\servername

把系统时间设置为服务器的时间：
net time \\servername /set /y

[fuxc]

下面是通过取得net time命令结果读取服务器时间。


Option Explicit
Private Declare Function CreatePipe Lib "kernel32" (phReadPipe As Long, phWritePipe As Long, lpPipeAttributes As SECURITY_ATTRIBUTES, ByVal nSize As Long) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, ByVal lpBuffer As String, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, ByVal lpOverlapped As Any) As Long
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Private Type STARTUPINFO
cb As Long
lpReserved As String
lpDesktop As String
lpTitle As String
dwX As Long
dwY As Long
dwXSize As Long
dwYSize As Long
dwXCountChars As Long
dwYCountChars As Long
dwFillAttribute As Long
dwFlags As Long
wShowWindow As Integer
cbReserved2 As Integer
lpReserved2 As Long
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type
Private Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessId As Long
dwThreadId As Long
End Type
Private Declare Function CreateProcessAsUser Lib "advapi32.dll" Alias "CreateProcessAsUserA" (ByVal hToken As Long, ByVal lpApplicationName As String, ByVal lpCommandLine As String, ByVal lpProcessAttributes As SECURITY_ATTRIBUTES, ByVal lpThreadAttributes As SECURITY_ATTRIBUTES, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, ByVal lpEnvironment As String, ByVal lpCurrentDirectory As String, ByVal lpStartupInfo As STARTUPINFO, ByVal lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function CreateProcessA Lib "kernel32" (ByVal lpApplicationName As Long, ByVal lpCommandLine As String, lpProcessAttributes As SECURITY_ATTRIBUTES, lpThreadAttributes As SECURITY_ATTRIBUTES, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Const NORMAL_PRIORITY_CLASS = &H20
Private Const STARTF_USESTDHANDLES = &H100
Private Const STARTF_USESHOWWINDOW = &H1
Private Function ExecuteCommandLineOutput(CommandLine As String, Optional BufferSize As Long = 256, Optional TimeOut As Long) As String
Dim Proc As PROCESS_INFORMATION
Dim Start As STARTUPINFO
Dim SA As SECURITY_ATTRIBUTES
Dim hReadPipe As Long
Dim hWritePipe As Long
Dim lBytesRead As Long
Dim sBuffer As String
If VBA.Len(CommandLine) > 0 Then
SA.nLength = Len(SA)
'sa.nLength = vba.Len(sa)
SA.bInheritHandle = 1&
SA.lpSecurityDescriptor = 0&
If CreatePipe(hReadPipe, hWritePipe, SA, 0) > 0 Then
Start.cb = Len(Start)
Start.dwFlags = STARTF_USESTDHANDLES Or STARTF_USESHOWWINDOW
Start.hStdOutput = hWritePipe
Start.hStdError = hWritePipe
If CreateProcessA(0&, CommandLine, SA, SA, 1&, NORMAL_PRIORITY_CLASS, 0&, 0&, Start, Proc) = 1 Then
CloseHandle hWritePipe
sBuffer = VBA.String(BufferSize, VBA.Chr(0))
If TimeOut > 0 Then
Dim BeginTime As Date
BeginTime = VBA.Now
End If
Do Until ReadFile(hReadPipe, sBuffer, BufferSize, lBytesRead, 0&) = 0
DoEvents
If TimeOut > 0 Then
If VBA.DateDiff("s", BeginTime, VBA.Now) > TimeOut Then
ExecuteCommandLineOutput = "Timeout"
Exit Do
End If
End If
ExecuteCommandLineOutput = ExecuteCommandLineOutput & VBA.Trim(VBA.Replace(VBA.Left(sBuffer, lBytesRead), VBA.Chr(0), ""))
Loop
CloseHandle Proc.hProcess
CloseHandle Proc.hThread
CloseHandle hReadPipe
Else
ExecuteCommandLineOutput = "File or command not found"
End If
Else
ExecuteCommandLineOutput = "CreatePipe failed. Error: " & Err.LastDllError & "."
End If
End If
End Function

Private Sub Form_Load()
Dim ServerName As String
Dim ServerTime As String
ServerName = "MyServer" '此处放服务器名称
ServerTime = ExecuteCommandLineOutput("net time \\" & ServerName, , 0) '截获Dos命令输出
MsgBox ServerTime
'从字符串截取日起，时间（在win2k下通过,9x未经测试）
MsgBox Mid(ServerTime, InStr(Len(ServerName) + 4, ServerTime, " "), InStr(Len(ServerName) + 4, ServerTime, vbCrLf) - InStr(Len(ServerName) + 4, ServerTime, " "))
End Sub