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
Next
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
加好友 
发短信
Post By：2012/12/20 19:14:00 [显示全部帖子]
