Public Function GetBeijingTime() As DateTime
湛河网站建设公司创新互联公司,湛河网站设计制作，有大型网站制作公司丰富经验。已为湛河上1000+提供企业网站建设服务。企业网站搭建\外贸网站制作要多少钱，请找那个售后服务好的湛河做网站的公司定做！
Dim dt As DateTime
Dim wrt As WebRequest = Nothing
Dim wrp As WebResponse = Nothing
Try
wrt = WebRequest.Create("")
wrp = wrt.GetResponse()
Dim html As String = String.Empty
Using stream As Stream = wrp.GetResponseStream()
Using sr As New StreamReader(stream, Encoding.UTF8)
html = sr.ReadToEnd()
End Using
End Using
Dim tempArray As String() = html.Split(";"c)
For i As Integer = 0 To tempArray.Length - 1
tempArray(i) = tempArray(i).Replace(vbCr vbLf, "")
Next
Dim year As String = tempArray(1).Split("="c)(1)
Dim month As String = tempArray(2).Split("="c)(1)
Dim day As String = tempArray(3).Split("="c)(1)
Dim hour As String = tempArray(5).Split("="c)(1)
Dim minite As String = tempArray(6).Split("="c)(1)
Dim second As String = tempArray(7).Split("="c)(1)
dt = DateTime.Parse(year "-" month "-" day " " hour ":" minite ":" second)
Catch generatedExceptionName As WebException
Return DateTime.Parse("2011-1-1")
Catch generatedExceptionName As Exception
Return DateTime.Parse("2011-1-1")
Finally
If wrp IsNot Nothing Then
wrp.Close()
End If
If wrt IsNot Nothing Then
wrt.Abort()
End If
End Try
Return dt
End Function
下列代码不用任何控件就能从国家授时中心网页获取时间获得网络时间。
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 = "" '从国家授时中心网页获取时间
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秒，如果多次运行或加上网络延时校正代码可进一步减少误差。
运行代码后，可以用第三方软件或到国家授时中心网站查看本机时间与标准时间的误差以验证代码的效果，当然更可以用第三方软件来校正电脑时间，这样误差将不超过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
直接用vb转换GMT时间
Private Function getWebDatetime() As String
Dim XmlHttp As Object
Set XmlHttp = CreateObject("Microsoft.XMLHTTP")
XmlHttp.Open "POST", "", False
XmlHttp.send
getWebDatetime = CDate(1 / 3 + CDbl(CDate(Mid$(XmlHttp.getResponseHeader("Date"), 5, 21))))
Set XmlHttp = Nothing
End Function
扩展资料：
读取网站服务器返回的时间的代码
Private Function getWebDatetime() As String
Dim XmlHttp As Object, objJs As Object
Set XmlHttp = CreateObject("Microsoft.XMLHTTP")
XmlHttp.Open "POST", "", False
XmlHttp.send
Set objJs = CreateObject("msscriptcontrol.scriptcontrol")
objJs.Language = "jScript"
getWebDatetime = objJs.Eval("var dt = new Date('" XmlHttp.getResponseHeader("Date") "');var date = [ [dt.getFullYear(), dt.getMonth() + 1, dt.getDate()].join('-'), [dt.getHours(), dt.getMinutes(), dt.getSeconds()].join(':')].join(' ').replace(/(?=\b\d\b)/g, '0');date;")
Set XmlHttp = Nothing
Set objJs = Nothing
End Function
Dim obj,OBJStatus As Object,url As String,GetText As String,i As Integer
Dim Retrieval
url=""
'判断网络是否连接
If url""Then
Retrieval=GetObject("winmgmts:\\.\root\cimv2")
obj=Retrieval.ExecQuery("Select*FromWin32_PingStatusWhereAddress='"Mid(url,8)"'")
For Each OBJStatus In obj
If IsNothing(OBJStatus.StatusCode) Or OBJStatus.StatusCode0 Then
Exit Sub
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.Readystate4 Then Exit Sub
GetText=.getAllResponseHeaders()
i=InStr(1,GetText,"date:",vbTextCompare)
If i0 Then'网页下载成功
i=InStr(i,GetText,",",vbTextCompare)
GetText= Trim(Mid(GetText,i+1))
i=InStr(1,GetText,"GMT",vbTextCompare)
GetText=GetText.Substring(0,i-1)' Left(GetText,i-1)
MsgBox ("网络时间:"GetText)
End If
End With
Retrieval=Nothing
OBJStatus=Nothing
obj=Nothing