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 |