不用控件获取网络时间的VB代码

[vb]代码库

Function NetTime(Optional url As String) As String  '返回包括时间和日期的字符串

   Dim obj, OBJStatus,  Retrieval   

   Dim GetText As String

   Dim i As Long   

   Dim myDate As Date

   Set Retrieval = CreateObject("Microsoft.XMLHTTP")   

    If url = "" Then       

            url = "http://www.time.ac.cn/stime.asp" '从国家授时中心网页获取时间

    End If

   '通过下载网页头信息获取网络时间

   On Error Goto ToExit       

   With Retrieval

            .Open "Get", url, False, "", ""

            .setRequestHeader "If-Modified-Since", "0"

            .setRequestHeader "Cache-Control", "no-cache" 

            .setRequestHeader "Connection", "close"

            .Send

            If .Readystate <> 4 Then Exit Function

            GetText = .getAllResponseHeaders()

            i = InStr(1, GetText, "date:", vbTextCompare) 

           If i > 0 Then  '网页下载成功

                i = InStr(i, GetText, ",", vbTextCompare)

                GetText = Trim(Mid(GetText, i + 1))

                i = InStr(1, GetText, " GMT", vbTextCompare) 

               GetText = Left(GetText, i - 1)

                myDate = GetText '字符串变为时间类型

                myDate = myDate + #8:00:00 AM#   '将时间转化为北京时间

                NetTime = myDate  '将时间转化为字符串

            End If

        End With

ToExit:

    Set Retrieval = Nothing

    Set OBJStatus = Nothing

    Set obj = Nothing

End Function

    下列代码利用上述NetTime函数，可以将本机时间同步到标准时间，误差一般不超过1秒，如果多次运行或加上网络延时校正代码可进一步减少误差。

    运行代码后，可以用时间精灵控件或到http://www.time.ac.cn/stime.asp网站查看本机时间与标准时间的误差以验证代码的效果，当然更可以用时间精灵来校正你的电脑时间，这样误差将不超过0.1秒！这是VB中用Time语句设定本机时间无法实现的，因为Time语句的“分辨率”只能达到整秒。

Sub UpDateTime()

    Dim sTime as String

    sTime=NetTime()

    On Error Resume Next

    If Stime<>"" Then

        Time=sTime

        Date=sTime

    End If

End Sub