Foxtable(狐表)用户栏目专家坐堂 → [求助]这段获取网络时间的代码在Foxtable中怎样应用?


  共有11918人关注过本帖树形打印复制链接

主题:[求助]这段获取网络时间的代码在Foxtable中怎样应用?

帅哥哟,离线,有人找我吗?
blueskyyq
  1楼 | 信息 | 搜索 | 邮箱 | 主页 | UC


加好友 发短信
等级:童狐 帖子:295 积分:1856 威望:0 精华:1 注册:2012/7/9 23:25:00
[求助]这段获取网络时间的代码在Foxtable中怎样应用?  发帖心情 Post By:2012/12/20 17:56:00 [只看该作者]

大家帮忙看看这段获取网络时间的VB代码在Foxtable中怎么用?

 

Private Sub Command1_Click()
Dim obj, OBJStatus, url, GetText, i
Dim Retrieval
    url = "http://www.baidu.com"
    '判断网络是否连接
    If url <> "" Then
        Set Retrieval = GetObject("winmgmts:\\.\root\cimv2")
        Set obj = Retrieval.ExecQuery("Select * From Win32_PingStatus Where Address = '" & Mid(url, 8) & "'")
        For Each OBJStatus In obj
            If IsNull(OBJStatus.StatusCode) Or OBJStatus.StatusCode <> 0 Then
                Exit Sub
            Else
                Exit For '已连接则继续
            End If
        Next
    End If
   
    '通过下载网页头信息获取网络时间
    Set 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 Sub
        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)
            MsgBox "网络时间:" & GetText
        End If
    End With
    Set Retrieval = Nothing
    Set OBJStatus = Nothing
    Set obj = Nothing
End Sub

 

[此贴子已经被作者于2012-12-20 18:27:40编辑过]

 回到顶部
帅哥哟,离线,有人找我吗?
狐狸爸爸
  2楼 | 信息 | 搜索 | 邮箱 | 主页 | UC


加好友 发短信
等级:管理员 帖子:47448 积分:251048 威望:0 精华:91 注册:2008/6/17 17:14:00
  发帖心情 Post By:2012/12/20 18:22:00 [只看该作者]

获取国际标准时间,记得考虑时差:

 

 下载信息  [文件大小:   下载次数: ]
图片点击可在新窗口打开查看点击浏览该文件:管理项目78.table

结果加上8小时,就是北京时间。

[此贴子已经被作者于2012-12-20 18:24:41编辑过]

[本帖被加为精华]
 回到顶部
帅哥哟,离线,有人找我吗?
blueskyyq
  3楼 | 信息 | 搜索 | 邮箱 | 主页 | UC


加好友 发短信
等级:童狐 帖子:295 积分:1856 威望:0 精华:1 注册:2012/7/9 23:25:00
  发帖心情 Post By:2012/12/20 18:24:00 [只看该作者]

谢谢狐爸,参考下

 回到顶部
帅哥哟,离线,有人找我吗?
布莱克朱
  4楼 | 信息 | 搜索 | 邮箱 | 主页 | UC


加好友 发短信
等级:三尾狐 帖子:623 积分:3897 威望:0 精华:0 注册:2011/8/3 22:13:00
  发帖心情 Post By:2012/12/20 19:14:00 [只看该作者]

这段代码 有问题吧  你自己测试下

在全局代码中  拷贝进去

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)
        MsgBox("网络时间:" & GetText)
    End If
End With
Retrieval = Nothing
OBJStatus = Nothing
obj = Nothing
End Function



命令窗口
Dim d As Date
Output.Show(newTime(D))

 我出来的是 网络时间: 2012-12-20 11:13:37


 回到顶部
帅哥哟,离线,有人找我吗?
lin_hailun
  5楼 | 信息 | 搜索 | 邮箱 | 主页 | UC


加好友 发短信
等级:狐神 帖子:6708 积分:34304 威望:0 精华:11 注册:2012/8/18 23:10:00
  发帖心情 Post By:2012/12/20 19:26:00 [只看该作者]

 好用,测试都有效,收藏一下。

 回到顶部
帅哥哟,离线,有人找我吗?
布莱克朱
  6楼 | 信息 | 搜索 | 邮箱 | 主页 | UC


加好友 发短信
等级:三尾狐 帖子:623 积分:3897 威望:0 精华:0 注册:2011/8/3 22:13:00
  发帖心情 Post By:2012/12/20 19:31:00 [只看该作者]

原来需要加上8  那这样改:

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


命令窗口:

Dim d As Date
newtime(d)

 回到顶部
帅哥哟,离线,有人找我吗?
布莱克朱
  7楼 | 信息 | 搜索 | 邮箱 | 主页 | UC


加好友 发短信
等级:三尾狐 帖子:623 积分:3897 威望:0 精华:0 注册:2011/8/3 22:13:00
  发帖心情 Post By:2012/12/20 19:43:00 [只看该作者]

老大自己给自己打个精华

 回到顶部
帅哥哟,离线,有人找我吗?
blueskyyq
  8楼 | 信息 | 搜索 | 邮箱 | 主页 | UC


加好友 发短信
等级:童狐 帖子:295 积分:1856 威望:0 精华:1 注册:2012/7/9 23:25:00
  发帖心情 Post By:2012/12/20 19:56:00 [只看该作者]

谢谢朱兄,精华!

狐爸别光顾着给自己精华啊,给朱兄也来个精


 回到顶部
帅哥哟,离线,有人找我吗?
e-png
  9楼 | 信息 | 搜索 | 邮箱 | 主页 | UC


加好友 发短信
等级:七尾狐 帖子:1695 积分:10725 威望:0 精华:0 注册:2009/10/25 16:45:00
  发帖心情 Post By:2012/12/20 19:59:00 [只看该作者]

以下是引用布莱克朱在2012-12-20 19:43:00的发言:
老大自己给自己打个精华

呵呵,他说过精华是为引起重视,让人学习用。


 回到顶部
帅哥哟,离线,有人找我吗?
blueskyyq
  10楼 | 信息 | 搜索 | 邮箱 | 主页 | UC


加好友 发短信
等级:童狐 帖子:295 积分:1856 威望:0 精华:1 注册:2012/7/9 23:25:00
  发帖心情 Post By:2012/12/20 20:02:00 [只看该作者]

嗯,也能促进广大狐友答疑及分享的积极性

 回到顶部
总数 11 1 2 下一页