SKY外语计算机学习

标题: vb做的一个自动更新系统时间的小东西 [打印本页]

作者: SKY定格    时间: 2014-4-11 09:38
标题: vb做的一个自动更新系统时间的小东西
电脑的纽扣电池没电了  开机时间总是不对于是就做了这个更新时间的    同样情况的可以把这个小东西设置拖到开始-程序-启动   就可以自启动了(代码里面没有设置自启动怕被杀,)不过需要联网哈拨号连接的就只能拨完号手动打开程序了    (打开后就更新时间没窗口的)
上代码:
  1. Option Explicit

  2. '获取网页源码
  3. Public Function GetHtmlCode(ByVal URL As String, Optional UTF8 As Boolean) As String
  4.     Dim xmlHTTP As Object
  5.     Dim objStream As Object
  6.     Dim strObjName As String
  7.     On Error GoTo ToExit
  8.     'Microsoft.xmlHTTP '这样做是为了不被某些杀软杀掉
  9.     strObjName = Chr$(562 Xor 639) & Chr$(480 Xor 393) & Chr$(262 Xor 357) & Chr$(653 Xor 767) & Chr$(469 Xor 442) & Chr$(293 Xor 342) & Chr$(558 Xor 577) & Chr$(755 Xor 661) & Chr$(427 Xor 479) & Chr$(420 Xor 394) & Chr$(177 Xor 233) & Chr$(907 Xor 966) & Chr$(435 Xor 511) & Chr$(860 Xor 788) & Chr$(110 Xor 58) & Chr$(382 Xor 298) & Chr$(29 Xor 77)
  10.     Set xmlHTTP = CreateObject(strObjName)
  11.     With xmlHTTP
  12.         If Left$(LCase$(URL), 7) <> "http://" Then URL = "http://" & URL
  13.         .Open "GET", URL, True
  14.         .send
  15.         Do Until .ReadyState = 4
  16.             DoEvents
  17.         Loop
  18.     End With
  19.     Set objStream = CreateObject("adodb.stream")
  20.     With objStream
  21.         .Type = 1
  22.         .Mode = 3
  23.         .Open
  24.         .Write xmlHTTP.responseBody
  25.         .position = 0
  26.         .Type = 2
  27.         .Charset = IIf(UTF8 = True, "UTF-8", "GB2312")
  28.         GetHtmlCode = .ReadText
  29.         .Close
  30.     End With
  31.     Set xmlHTTP = Nothing
  32.     Set objStream = Nothing
  33. ToExit:
  34.     Set xmlHTTP = Nothing
  35.     Set objStream = Nothing
  36. End Function


  37. Private Function getTime() As Date
  38. Dim Regex As Object, ms As Object
  39. Dim HTML As String
  40. HTML = GetHtmlCode("http://open.baidu.com/special/time/", True)
  41. Set Regex = CreateObject("VBSCRIPT.REGEXP")
  42. Regex.IgnoreCase = True
  43. Regex.Pattern = "window.baidu_time\(([0-9]{13})\);"
  44. Set ms = Regex.Execute(HTML)
  45. If ms.Count = 0 Then
  46. getTime = Now()
  47. Else
  48. Dim t As String
  49. Dim q As String
  50. Dim tt As Long
  51. tt = Val(ms.Item(0).SubMatches(0) / 1000)
  52. t = FromUnixTime(tt, 8)

  53. If IsDate(t) Then getTime = CDate(t) Else getTime = Now()
  54. q = Format(t, "yyyy-MM-dd HH:mm:ss")
  55. 'Print Mid(q, 1, 10)
  56. 'Print Mid(q, 12, 8)
  57. 'Print q
  58. 'Print t
  59. 'Print Now
  60. Date = Mid(q, 1, 10)
  61. Time = Mid(q, 12, 8)
  62. End If

  63. End Function
  64. Function FromUnixTime(intTime, intTimeZone) '把Unix时间戳便改为常用的形式
  65.     If IsEmpty(intTime) Or Not IsNumeric(intTime) Then
  66.          FromUnixTime = Now()
  67.         Exit Function
  68.     End If
  69.     If IsEmpty(intTime) Or Not IsNumeric(intTimeZone) Then intTimeZone = 0
  70.      FromUnixTime = DateAdd("s", intTime, "1970-1-1 0:0:0")
  71.      FromUnixTime = DateAdd("h", intTimeZone, FromUnixTime)
  72. End Function

  73. Private Sub Form_Load()
  74. Me.Hide
  75. getTime
  76. Unload Me
  77. End Sub
复制代码





欢迎光临 SKY外语计算机学习 (http://www.skywj.com/) Powered by Discuz! X2.5