●●●如何取得真实日期时间的问题●●●

Question

我的一个程序，只允许每月的单数日的双数时间才能运行。如今天是3月30号，今天一天都不能运行明天是3月31日，明天的1，3，5，7，11，13，15，17，19，21，23点可以运行。算法部分我倒也没有什么问题，难度就是：如果有人把这台机器的系统时间随意更改，我这个设计就毫无意义。我想请大家谁能给出取得当前真实时间的办法？不论它怎么改自己的系统时间，我的程序都能判断出现在的真实时间！我想，也只有上网验证才可以了，但是不知道哪里能有时时提供当前时间的地方，。而且能被我的VB程序读到？ 我倒是有一个FTP服务器和WEB服务器，我在上面上了一个页面，但是我得每隔1小时去更新一下他的页面，异常痛苦。现在：1）谁能解决网页时间自动更新的问题，假如一个网页 http://www.myweb.com/time.ini 里面有一个时间串， 20:15 我希望在21点15分的时候，time.ini里面的字符串能自动变成21:15
如果上面实现起来有难度，第二方案：
2）谁能提供一个全天24小时无休的准确提供当前真实的东八区（适用于中华人民共和国大陆地区）的时间， 别说time.microsoft.com 哦！ 我10次连他9次失败！！或者您有更加好的解决办法，请跟帖讨论。谢谢。

Answer 1

网上下载一些“对时间”的软件如“原子钟”、“Chronograph”。里面有很多服务器的地址，如time.nist.gov

Answer 2

我用的是Chronograph，里面有很多服务器地址，大概自己会一个一个地找服务器。我一般不到一分钟就有准确时间的数据了。

Answer 3

我安装好了Chronograph4.0 里面也有很多的服务器列表
但是我该如何与他们交流？从他们那里得到现在的确切时间？
我找到了一个代码窗体:Private Declare Sub GetSystemTime Lib "kernel32" (lpSystemTime As SYSTEMTIME)Private Declare Function SetSystemTime Lib "kernel32" (lpSystemTime As SYSTEMTIME) As LongPrivate Sub Command1_Click() 'Main button to set the system
    ' time
    On Error GoTo ErrHandler    Label3.Caption = "System Time has Not been Set Yet"    SetIt = 1 'Used to only set time if the time from the
        ' time server is valid and reportedly accurate    If Winsock1.State <> sckClosing Then 'Sometimes the
        ' Winsock gets delayed in the closing state, so
        ' make sure it is closed before trying again
       If Winsock1.State = sckClosed Then 'If closed, ok to
           ' open, else close it
          Timer1.Interval = 5000 'Start 5 second count to
              ' 'time' server
          Timer1.Enabled = True
          Screen.MousePointer = vbHourglass
          Winsock1.LocalPort = 0 'Must be set to 0
          Winsock1.RemoteHost = Trim$(Text1.Text) 'Address
              ' of NIST server
          Winsock1.RemotePort = 13 '13, 37 or 123 'Use 13!
          Winsock1.Protocol = 0 '1-UDP '0-TCP 'USE TCP!
          Winsock1.Connect 'This is what goes out and gets
              ' the time
       Else
          Winsock1.Close
          Screen.MousePointer = vbNormal
          Timer1.Interval = 0
          Timer1.Enabled = False
       End If
    Else
       Winsock1.Close
       Screen.MousePointer = vbNormal
       Timer1.Interval = 0
       Timer1.Enabled = False
    End If
    
    Exit Sub
ErrHandler:
    SetIt = 0
    Screen.MousePointer = vbNormal
    Timer1.Interval = 0
    Timer1.Enabled = False
    MsgBox "The Winsock Connection is Unavailable."
    Winsock1.Close
End Sub
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long) _
    'Fires when data is received from server
Dim datDate As Date 'formatted date
Dim strData As String 'time string from net time server
Dim JSys As SYSTEMTIME
Dim RetVal As Integer
Dim Ct As Integer    On Error GoTo ErrHandler
    
    Winsock1.GetData strData, vbString 'get string from
        ' server
    datDate = FormatDateTime(strData) 'go format the new
        ' string
    
    If msAdj <> 0 Then 'if msadj = 0 then do not set an
        ' offset
       datDate = DateAdd("s", -1, datDate) 'only if msadj
           ' <> 0, subtract 1 sec from new time so addition
           ' of msadj is positive
    End If
    
    Label1.Caption = "Before " & Now 'time before adjustment
    
    If SetIt = 1 Then 'If all is ok, set system time
    
       'Initialize SYSTIME with new data
       JSys.wYear = Year(datDate)
       JSys.wMonth = Month(datDate)
       JSys.wDayOfWeek = 0 'DayOfWeek(datDate)'Not used
       JSys.wHour = Hour(datDate)
       JSys.wMinute = Minute(datDate)
       JSys.wSecond = Second(datDate)
       JSys.wDay = Day(datDate)
       
       MsgBox JSys.wMinute
       
       If msAdj = 0 Then
          JSys.wMilliseconds = 0 'No millisec offset
       Else
          JSys.wMilliseconds = ((10000 - msAdj) / 10) 'must
              ' be positive
       End If
       
       'Set system time with new data
       Do Until RetVal <> 0 Or Ct > 9 'Make up to 10
           ' attempts to set the time
          RetVal = SetSystemTime(JSys)
          Ct = Ct + 1
       Loop
       
       Label2.Caption = "After " & Now 'time after
           ' adjustment
       
       If RetVal <> 0 Then
          Label3.Caption = "System Time was Set " & _
              "Successfully"
       Else
          Label3.Caption = "There was an Error in Setting " & _
              "Time"
       End If
       
       'Display time string that was sent from server
       Text2.Text = strData
    End If
    
    SetIt = 0
    Winsock1.Close
    Screen.MousePointer = vbNormal
    Timer1.Interval = 0
    Timer1.Enabled = False
    
    Exit Sub
ErrHandler:
    SetIt = 0
    Winsock1.Close
    Screen.MousePointer = vbNormal
    Timer1.Interval = 0
    Timer1.Enabled = False
End Sub模版：
Type SYSTEMTIME ' 16 Bytes
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我再Text1.Text里面输入：nist1-sj.glassey.com点了Command1,Label3.caption一直显示System Time has Not been Set Yet沙漏后没有反应！

Answer 4

如果楼主有自己的WEB服务器，最简单的方法就是在上面放一个 .asp 或 .aspx 之类的文件，
这个文件的唯一功能就是生成一个 text 框，里面放的是web服务器的当前日期/时间；
然后用你的程序通过 webbrowser 控件访问这个文件，获取 text 框的内容即可。注意：如果WEB服务器不是你自己能控制的，请注意时差问题。比如如果使用美国的服务器，得到 text 内容后要调整时差才是正确的数据。

Answer 5

模块中Option Explicit
Dim HTTP As XMLHTTP
Public Function GetTheContent(src As String) As String    'src 目标URL地址
Set HTTP = New XMLHTTPIf src <> "" Then
     HTTP.open "GET", src, False
     HTTP.send
         
    If HTTP.readyState <> 4 Then
        Exit Function
    End If
    GetTheContent = BytesToBstr(HTTP.responseBody, "GB2312")
    Set HTTP = Nothing
    If Err.Number <> 0 Then Err.Clear
Else
    GetTheContent = "no source"
    
End If
End FunctionPrivate Function BytesToBstr(body, Cset) As String  '文字转换
Dim objstream As New ADODB.streamobjstream.Type = 1
objstream.Mode = 3
objstream.open
objstream.Write bodyobjstream.Position = 0
objstream.Type = 2
objstream.Charset = Cset
BytesToBstr = objstream.ReadText
objstream.Close
Set objstream = Nothing
End Function窗体中Private Sub Command1_Click()
    Dim freeNO As Integer
    Dim strGet As String
    freeNO = FreeFile
   strGet = GetTheContent("http://www.people.com.cn/")
  If strGet = "" Then
    MsgBox "get failed"
    Exit Sub
  End If
  
  Open "c:\1.txt" For Output As freeNO  Write #freeNO, strGet
  
  Close #freeNO
  
  
  
End Sub打开 记事本你就可以看到日期了。（2005年03月31日 星期四）以下的查找打操作很简单，相信你自己能搞定了。

Answer 6

http://www.people.com.cn/ 网站的时间准不准我不懂你自己找一个好的吧

Answer 7

http://search.csdn.net/Expert/topic/2460/2460678.xml?temp=.3926355

Answer 8

http://www.time.ac.cn/的时间是准的，
用以上链接中ch21st(www.blanksoft.com)回复中的代码，可以得到一个字符串，分析出时间

Answer 9

谢谢  viena(维也纳nn-实心木头人)