form1.frm

迷你网络校时

VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Begin VB.Form Form1 
   BackColor       =   &H00C8D0D4&
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "迷你网络校时"
   ClientHeight    =   1230
   ClientLeft      =   6120
   ClientTop       =   5430
   ClientWidth     =   3435
   HasDC           =   0   'False
   Icon            =   "Form1.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   NegotiateMenus  =   0   'False
   ScaleHeight     =   1230
   ScaleWidth      =   3435
   StartUpPosition =   2  '屏幕中心
   Begin VB.Timer Timer2 
      Enabled         =   0   'False
      Interval        =   10000
      Left            =   5265
      Top             =   495
   End
   Begin VB.Timer Timer1 
      Interval        =   1000
      Left            =   4770
      Top             =   495
   End
   Begin VB.Timer Timer3 
      Enabled         =   0   'False
      Interval        =   10000
      Left            =   5760
      Top             =   495
   End
   Begin VB.Frame Frame1 
      BackColor       =   &H00C8D0D4&
      Height          =   1050
      Left            =   120
      TabIndex        =   0
      Top             =   60
      Width           =   3210
      Begin VB.Image Image1 
         Appearance      =   0  'Flat
         Height          =   240
         Left            =   2790
         Picture         =   "Form1.frx":030A
         Top             =   675
         Width           =   240
      End
      Begin VB.Label labMsg 
         Appearance      =   0  'Flat
         BackColor       =   &H80000005&
         BackStyle       =   0  'Transparent
         BeginProperty Font 
            Name            =   "Tahoma"
            Size            =   9
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H00000000&
         Height          =   240
         Left            =   150
         TabIndex        =   3
         Top             =   675
         UseMnemonic     =   0   'False
         Width           =   2610
      End
      Begin VB.Label labTime 
         Alignment       =   2  'Center
         Appearance      =   0  'Flat
         BackColor       =   &H00FFFFFF&
         BorderStyle     =   1  'Fixed Single
         BeginProperty Font 
            Name            =   "Tahoma"
            Size            =   9
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H00000000&
         Height          =   255
         Left            =   1035
         TabIndex        =   2
         Top             =   270
         UseMnemonic     =   0   'False
         Width           =   2010
      End
      Begin VB.Label Label1 
         Appearance      =   0  'Flat
         BackColor       =   &H80000005&
         BackStyle       =   0  'Transparent
         Caption         =   "本机时间:"
         BeginProperty Font 
            Name            =   "Tahoma"
            Size            =   9
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H00000000&
         Height          =   210
         Left            =   150
         TabIndex        =   1
         Top             =   285
         UseMnemonic     =   0   'False
         Width           =   780
      End
   End
   Begin MSWinsockLib.Winsock Winsock1 
      Index           =   0
      Left            =   6300
      Top             =   495
      _ExtentX        =   741
      _ExtentY        =   741
      _Version        =   393216
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Dim SvrName(14) As String

Private Sub SetTime()
    On Error Resume Next
    Dim i As Long
    For i = 1 To 14
        With Winsock1(i)
            If .State = 9 Then Exit Sub
            If .State > 0 Then .Close
            .Connect SvrName(i), 13
        End With
    Next
    Timer2.Enabled = True
    labMsg.Caption = "开始校时..."
End Sub

Private Sub Form_Load()
    Dim i As Long
    SvrName(1) = "time.nist.gov"                'NCAR, Boulder, Colorado  192.43.244.18
    SvrName(2) = "time-a.nist.gov"              'NIST, Gaithersburg, Maryland  129.6.15.28
    SvrName(3) = "time-b.nist.gov"              'NIST, Gaithersburg, Maryland  129.6.15.29
    SvrName(4) = "time-a.timefreq.bldrdoc.gov"  'NIST, Boulder, Colorado  132.163.4.101
    SvrName(5) = "time-b.timefreq.bldrdoc.gov"  'NIST, Boulder, Colorado  132.163.4.102
    SvrName(6) = "time-c.timefreq.bldrdoc.gov"  'NIST, Boulder, Colorado  132.163.4.103
    SvrName(7) = "utcnist.colorado.edu"         'University of Colorado, Boulder  128.138.140.44
    SvrName(8) = "time-nw.nist.gov"             'Microsoft, Redmond, Washington 131.107.1.10
    SvrName(9) = "nist1.datum.com"              'Datum, San Jose, California  66.243.43.21
    SvrName(10) = "nist1.dc.glassey.com"        'Abovenet, Virginia  216.200.93.8
    SvrName(11) = "nist1.ny.glassey.com"        'Abovenet, New York City  208.184.49.9
    SvrName(12) = "nist1.sj.glassey.com"        'Abovenet, San Jose, California  207.126.103.204
    SvrName(13) = "nist1.aol-ca.truetime.com"   'TrueTime, AOL facility, Sunnyvale, CA  207.200.81.113
    SvrName(14) = "nist1.aol-va.truetime.com"   'TrueTime, AOL facility, Virginia  205.188.185.33
    For i = 1 To 14
        Load Winsock1(i)
    Next
    labTime.Caption = Format$(Now, "yyyy-mm-dd  hh:mm:ss")
    Call SetTime
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Dim i As Long
    For i = 1 To 14
        Unload Winsock1(i)
    Next
    Erase SvrName
    End
End Sub

Private Sub Image1_Click()
    Dim s As String
    s = "迷你网络校时v1.0" & vbCrLf & vbCrLf & _
        "以美国标准技术研究所(NIST)的互联网时间服务器为标准, " & vbCrLf & _
        "设置本机时间为北京时间, 误差在2秒内。" & vbCrLf & vbCrLf & _
        "制作： 冯桦 2005.8.22 <[e-mail]>" & vbCrLf
    MsgBox s
End Sub

Private Sub Timer1_Timer()
    labTime.Caption = Format$(Now, "yyyy-mm-dd  hh:mm:ss")
End Sub

Private Sub Timer2_Timer()
    Call SetTime
End Sub

Private Sub Timer3_Timer()
    Unload Me
End Sub

Private Sub Winsock1_DataArrival(Index As Integer, ByVal bytesTotal As Long)
    On Error Resume Next
    Dim s As String
    Dim dt As Date
    Winsock1(Index).GetData s, vbString
    
    If Mid$(s, 31, 1) <> "0" Then Exit Sub 'Server is not health
    If Me.Tag = "ok" Then Exit Sub 'choose the quick server
    
    Me.Tag = "ok"
    dt = CDate(Mid$(s, 8, 17)) + 8# / 24#
    Date = dt
    Time = dt
    labMsg = labMsg & "成功!  10秒后关闭!" & vbCrLf
    Timer2.Enabled = False
    Timer3.Enabled = True
End Sub