vb點(diǎn)虐 獲取互聯(lián)網(wǎng)的北京時(shí)間

Public?Function?GetBeijingTime()?As?DateTime

湛河網(wǎng)站建設(shè)公司創(chuàng)新互聯(lián)公司,湛河網(wǎng)站設(shè)計(jì)制作，有大型網(wǎng)站制作公司豐富經(jīng)驗(yàn)。已為湛河上1000+提供企業(yè)網(wǎng)站建設(shè)服務(wù)。企業(yè)網(wǎng)站搭建\外貿(mào)網(wǎng)站制作要多少錢(qián)，請(qǐng)找那個(gè)售后服務(wù)好的湛河做網(wǎng)站的公司定做！

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

vb 獲取網(wǎng)絡(luò)時(shí)間

下列代碼不用任何控件就能從國(guó)家授時(shí)中心網(wǎng)頁(yè)獲取時(shí)間獲得網(wǎng)絡(luò)時(shí)間。

Function NetTime(Optional url As String) As String '返回包括時(shí)間和日期的字符串

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 = "" '從國(guó)家授時(shí)中心網(wǎng)頁(yè)獲取時(shí)間

End If

'通過(guò)下載網(wǎng)頁(yè)頭信息獲取網(wǎng)絡(luò)時(shí)間

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 '網(wǎng)頁(yè)下載成功

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

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

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

GetText = Left(GetText, i - 1)

myDate = GetText '字符串變?yōu)闀r(shí)間類(lèi)型

myDate = myDate + #8:00:00 AM# '將時(shí)間轉(zhuǎn)化為北京時(shí)間

NetTime = myDate '將時(shí)間轉(zhuǎn)化為字符串

End If

End With

ToExit:

Set Retrieval = Nothing

Set OBJStatus = Nothing

Set obj = Nothing

End Function

利用上述NetTime函數(shù)，可以將本機(jī)時(shí)間同步到標(biāo)準(zhǔn)時(shí)間，誤差一般不超過(guò)1秒，如果多次運(yùn)行或加上網(wǎng)絡(luò)延時(shí)校正代碼可進(jìn)一步減少誤差。

運(yùn)行代碼后，可以用第三方軟件或到國(guó)家授時(shí)中心網(wǎng)站查看本機(jī)時(shí)間與標(biāo)準(zhǔn)時(shí)間的誤差以驗(yàn)證代碼的效果，當(dāng)然更可以用第三方軟件來(lái)校正電腦時(shí)間，這樣誤差將不超過(guò)0.1秒。這是VB中用Time語(yǔ)句設(shè)定本機(jī)時(shí)間無(wú)法實(shí)現(xiàn)的，因?yàn)門(mén)ime語(yǔ)句的“分辨率”只能達(dá)到整秒。

Sub UpDateTime()

Dim sTime as String

sTime=NetTime()

On Error Resume Next

If Stime"" Then

Time=sTime

Date=sTime

End If

End Sub

vb 獲取網(wǎng)絡(luò)時(shí)間較快的代碼

直接用vb轉(zhuǎn)換GMT時(shí)間

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

擴(kuò)展資料：

讀取網(wǎng)站服務(wù)器返回的時(shí)間的代碼

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

vb。net怎么獲取網(wǎng)絡(luò)上的時(shí)間 坐等

Dim?obj,OBJStatus?As?Object,url?As?String,GetText?As?String,i?As?Integer

Dim?Retrieval

url=""

'判斷網(wǎng)絡(luò)是否連接

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'已連接則繼續(xù)

End?If

Next

End?If

'通過(guò)下載網(wǎng)頁(yè)頭信息獲取網(wǎng)絡(luò)時(shí)間

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'網(wǎng)頁(yè)下載成功

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?("網(wǎng)絡(luò)時(shí)間:"GetText)

End?If

End?With

Retrieval=Nothing

OBJStatus=Nothing

obj=Nothing