vb做的一个自动更新系统时间的小东西

SKY定格

电脑的纽扣电池没电了  开机时间总是不对于是就做了这个更新时间的    同样情况的可以把这个小东西设置拖到开始-程序-启动   就可以自启动了（代码里面没有设置自启动怕被杀，）不过需要联网哈拨号连接的就只能拨完号手动打开程序了    （打开后就更新时间没窗口的）
上代码：

1. Option Explicit
   
2. 
   
3. '获取网页源码
   
4. Public Function GetHtmlCode(ByVal URL As String, Optional UTF8 As Boolean) As String
   
5.     Dim xmlHTTP As Object
   
6.     Dim objStream As Object
   
7.     Dim strObjName As String
   
8.     On Error GoTo ToExit
   
9.     'Microsoft.xmlHTTP '这样做是为了不被某些杀软杀掉
   
10.     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)
    
11.     Set xmlHTTP = CreateObject(strObjName)
    
12.     With xmlHTTP
    
13.         If Left$(LCase$(URL), 7) <> "http://" Then URL = "http://" & URL
    
14.         .Open "GET", URL, True
    
15.         .send
    
16.         Do Until .ReadyState = 4
    
17.             DoEvents
    
18.         Loop
    
19.     End With
    
20.     Set objStream = CreateObject("adodb.stream")
    
21.     With objStream
    
22.         .Type = 1
    
23.         .Mode = 3
    
24.         .Open
    
25.         .Write xmlHTTP.responseBody
    
26.         .position = 0
    
27.         .Type = 2
    
28.         .Charset = IIf(UTF8 = True, "UTF-8", "GB2312")
    
29.         GetHtmlCode = .ReadText
    
30.         .Close
    
31.     End With
    
32.     Set xmlHTTP = Nothing
    
33.     Set objStream = Nothing
    
34. ToExit:
    
35.     Set xmlHTTP = Nothing
    
36.     Set objStream = Nothing
    
37. End Function
    
38. 
    
39. 
    
40. Private Function getTime() As Date
    
41. Dim Regex As Object, ms As Object
    
42. Dim HTML As String
    
43. HTML = GetHtmlCode("http://open.baidu.com/special/time/", True)
    
44. Set Regex = CreateObject("VBSCRIPT.REGEXP")
    
45. Regex.IgnoreCase = True
    
46. Regex.Pattern = "window.baidu_time\(([0-9]{13})\);"
    
47. Set ms = Regex.Execute(HTML)
    
48. If ms.Count = 0 Then
    
49. getTime = Now()
    
50. Else
    
51. Dim t As String
    
52. Dim q As String
    
53. Dim tt As Long
    
54. tt = Val(ms.Item(0).SubMatches(0) / 1000)
    
55. t = FromUnixTime(tt, 8)
    
56. 
    
57. If IsDate(t) Then getTime = CDate(t) Else getTime = Now()
    
58. q = Format(t, "yyyy-MM-dd HH:mm:ss")
    
59. 'Print Mid(q, 1, 10)
    
60. 'Print Mid(q, 12, 8)
    
61. 'Print q
    
62. 'Print t
    
63. 'Print Now
    
64. Date = Mid(q, 1, 10)
    
65. Time = Mid(q, 12, 8)
    
66. End If
    
67. 
    
68. End Function
    
69. Function FromUnixTime(intTime, intTimeZone) '把Unix时间戳便改为常用的形式
    
70.     If IsEmpty(intTime) Or Not IsNumeric(intTime) Then
    
71.          FromUnixTime = Now()
    
72.         Exit Function
    
73.     End If
    
74.     If IsEmpty(intTime) Or Not IsNumeric(intTimeZone) Then intTimeZone = 0
    
75.      FromUnixTime = DateAdd("s", intTime, "1970-1-1 0:0:0")
    
76.      FromUnixTime = DateAdd("h", intTimeZone, FromUnixTime)
    
77. End Function
    
78. 
    
79. Private Sub Form_Load()
    
80. Me.Hide
    
81. getTime
    
82. Unload Me
    
83. End Sub
    

复制代码