专家坐堂-显示的时间怎样才能一样，求助Foxtable(狐表) - 新一代数据库软件，完美融合Access、Foxpro、Excel、vb.net之优势，人人都能掌握的快速软件开发工具!

Public Function NewTime(ByVal p1 As Date) As Date

Dim obj, OBJStatus, url, GetText, i

Dim Retrieval

url = "http://www.baidu.com"

\'判断网络是否连接

If url <> "" Then

Retrieval = GetObject("winmgmts:\\\\.\\root\\cimv2")

obj = Retrieval.ExecQuery("Select * From Win32_PingStatus Where Address = \'" & Mid(url, 8) & "\'")

For Each OBJStatus In obj

If OBJStatus.StatusCode Is Nothing Or OBJStatus.StatusCode <> 0 Then

Exit Function

Else

Exit For \'已连接则继续

End If

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

Retrieval = CreateObject("Microsoft.XMLHTTP")

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)

Dim d As Date = GetText

d =d.AddHours(8)

MsgBox("网络时间:" & d)

\'MsgBox("网络时间:" & GetText)

End If

End With

Retrieval = Nothing

OBJStatus = Nothing

obj = Nothing

End Function