[已解决]如何用VBA 获取互联网日期

事后诸葛亮 · 发表于 2013-7-17 14:43

如何用VBA 获取互联网日期并返回日期值
不是从本电脑中用DATE获取，而是获取互联网上的日期。谢谢

最佳答案

月排行榜 / 总排行榜

wayy

2013-7-17 14:56

Sub getdate()
On Error Resume Next
Dim objXML As Object
Dim strTemp As String
Dim lStart As Long
Dim lEnd As Long
Dim DtWeb As Date
Dim arr() As String
DtWeb = #12/31/2010# '设置默认返回时间
'建立XMLHTTP对象。并获取<A href="http://www.timeanddate.com/worldclock/city.html?n=33">http://www.timeanddate.com/worldclock/city.html?n=33</A>的网页Text
'&Refresh=" & Rnd 是为了避免直接从IE缓存中读取
Set objXML = CreateObject("Microsoft.XMLHTTP")
Randomize '初始化随机数，避免IE缓存重复
objXML.Open "Get", "<A href="http://www.timeanddate.com/worldclock/city.html?n=33&Refresh">http://www.timeanddate.com/worldclock/city.html?n=33&Refresh</A>=" & Rnd, False '读取北京时间
objXML.sEnd ""
strTemp = objXML.responseText
'对网页进行处理，找出当前日期和时间
lStart = InStr(1, strTemp, "Current Time", vbTextCompare)
lEnd = InStr(lStart, strTemp, "", vbTextCompare)
strTemp = Mid(strTemp, lStart, lEnd - lStart)
strTemp = Replace(strTemp, "Current Time</th><td>", "")
arr() = Split(strTemp, ",", -1, vbTextCompare)
DtWeb = CDate(arr(1) & arr(2))
Set objXML = Nothing
'活动单元格输出日期和时间
ActiveCell.Value = DtWeb
End Sub

复制代码

跳转到最佳答案楼层

事后诸葛亮 · 发表于 2013-7-17 14:51

http://club.excelhome.net/forum.php?mod=viewthread&tid=787121
找到解决问题的办法了。
请版主删除本贴或都结案。谢谢。

wayy · 发表于 2013-7-17 14:56

Sub getdate()
On Error Resume Next
Dim objXML As Object
Dim strTemp As String
Dim lStart As Long
Dim lEnd As Long
Dim DtWeb As Date
Dim arr() As String
DtWeb = #12/31/2010# '设置默认返回时间
'建立XMLHTTP对象。并获取<A href="http://www.timeanddate.com/worldclock/city.html?n=33">http://www.timeanddate.com/worldclock/city.html?n=33</A>的网页Text
'&Refresh=" & Rnd 是为了避免直接从IE缓存中读取
Set objXML = CreateObject("Microsoft.XMLHTTP")
Randomize '初始化随机数，避免IE缓存重复
objXML.Open "Get", "<A href="http://www.timeanddate.com/worldclock/city.html?n=33&Refresh">http://www.timeanddate.com/worldclock/city.html?n=33&Refresh</A>=" & Rnd, False '读取北京时间
objXML.sEnd ""
strTemp = objXML.responseText
'对网页进行处理，找出当前日期和时间
lStart = InStr(1, strTemp, "Current Time", vbTextCompare)
lEnd = InStr(lStart, strTemp, "", vbTextCompare)
strTemp = Mid(strTemp, lStart, lEnd - lStart)
strTemp = Replace(strTemp, "Current Time</th><td>", "")
arr() = Split(strTemp, ",", -1, vbTextCompare)
DtWeb = CDate(arr(1) & arr(2))
Set objXML = Nothing
'活动单元格输出日期和时间
ActiveCell.Value = DtWeb
End Sub

复制代码

hwc2ycy · 发表于 2013-7-17 15:07

直接和时间服务器做同步吧。

事后诸葛亮 · 发表于 2013-7-17 16:27

本帖最后由事后诸葛亮于 2013-7-17 16:32 编辑

wayy 发表于 2013-7-17 14:56

好详细，还有代码注释，谢谢
不过出错了。郁闷
刚把代码放入VBE窗体就显示红色。
QQ截图20130717163026.jpg

运行时，报错。

事后诸葛亮 · 发表于 2013-7-17 16:27

hwc2ycy 发表于 2013-7-17 15:07
直接和时间服务器做同步吧。

谢谢，你回答我的问题总是那么的积极。哈哈。

wayy · 发表于 2013-7-17 16:37

本帖最后由 wayy 于 2013-7-17 16:41 编辑

事后诸葛亮发表于 2013-7-17 16:27
好详细，还有代码注释，谢谢
不过出错了。郁闷
刚把代码放入VBE窗体就显示红色。

还是直接贴代码吧{:1012:}

Sub getdate()
On Error Resume Next
Dim objXML As Object
Dim strTemp As String
Dim lStart As Long
Dim lEnd As Long
Dim DtWeb As Date
Dim arr() As String

DtWeb = #12/31/2010# '设置默认返回时间
'建立XMLHTTP对象。并获取<A href="http://www.timeanddate.com/worldclock/city.html?n=33">[url]http://www.timeanddate.com/worldclock/city.html?n=33</A[/url]>的网页Text
'&Refresh=" & Rnd 是为了避免直接从IE缓存中读取
Set objXML = CreateObject("Microsoft.XMLHTTP")
Randomize '初始化随机数，避免IE缓存重复
objXML.Open "Get", "http://www.timeanddate.com/worldclock/city.html?n=33&Refresh=" & Rnd, False '读取北京时间
objXML.sEnd ""
strTemp = objXML.responseText
'对网页进行处理，找出当前日期和时间
lStart = InStr(1, strTemp, "Current Time", vbTextCompare)
lEnd = InStr(lStart, strTemp, "", vbTextCompare)
strTemp = Mid(strTemp, lStart, lEnd - lStart)
strTemp = Replace(strTemp, "Current Time</th><td>", "")

arr() = Split(strTemp, ",", -1, vbTextCompare)
DtWeb = CDate(arr(1) & arr(2))
Set objXML = Nothing
'活动单元格输出日期和时间
ActiveCell.Value = DtWeb
End Sub

上清宫主 · 发表于 2013-7-17 16:47

这个的日期要短点

With CreateObject("InternetExplorer.Application")
.Visible = 0
.Navigate "http://www.nongli114.com/"
Do Until .Readystate = 4
DoEvents
Loop
MsgBox "今天是" & .document.all.tags("b")(0).outertext
.Quit
End With

事后诸葛亮 · 发表于 2013-7-17 17:08

上清宫主发表于 2013-7-17 16:47
这个的日期要短点
With CreateObject("InternetExplorer.Application")
.Visible = 0

人才呀。谢谢。
不过个人心里感觉，nongli114 有可能会改版之类的，这代码就会失效。
3楼的那个网址改版的可能性要小多了。呵呵。
而且运行你的代码的时候感觉好慢(卡)。

qwe12368 · 发表于 2017-8-9 12:42

wayy 发表于 2013-7-17 14:56

你好，请问你这个代码是放到：对象-thiswookbook --open，中吗？
开头和结尾是这样吗？Private Sub Workbook_Open()Sub getdate()
....................
....................
...................
ActiveCell.Value = DtWeb
End Sub

但是关闭重新打开并没有提示时间？
能帮我解决下吗谢谢

		自动登录	找回密码
密码			注册

[已解决]如何 用VBA 获取 互联网日期

浏览过的版块

[已解决]如何用VBA 获取互联网日期