frmmain.frm

本程序可以设置本机自动与Internet时间同步。

VERSION 5.00
Begin VB.Form frmMain 
   BorderStyle     =   0  'None
   Caption         =   "网络时间同步"
   ClientHeight    =   3615
   ClientLeft      =   3810
   ClientTop       =   3900
   ClientWidth     =   5610
   Icon            =   "frmMain.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   3615
   ScaleWidth      =   5610
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  '屏幕中心
   Begin Project1.Socket Winsock1 
      Left            =   120
      Top             =   2400
      _ExtentX        =   741
      _ExtentY        =   741
   End
   Begin VB.Timer get_time 
      Interval        =   60000
      Left            =   120
      Top             =   2880
   End
   Begin VB.Menu mSysPopup 
      Caption         =   "SysPopup"
      Begin VB.Menu mTimeSyn 
         Caption         =   "立即同步"
      End
      Begin VB.Menu mOption 
         Caption         =   "系统设置"
      End
      Begin VB.Menu mSep1 
         Caption         =   "-"
      End
      Begin VB.Menu mExit 
         Caption         =   "退出程序"
      End
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Dim mtime_zone$               '时区
Dim mblnFlag As Boolean       '同步时间标志

Private Sub Form_Resize()
    If Me.WindowState = vbMinimized Then Me.Hide
End Sub

Private Sub Form_Load()
    frmMain.Hide
    Set iniOp = New clsIniOp
    With iniOp
        .Inipath = App.Path & "\Config.ini" '指定路径
        strServer = .Getstr("Options", "TimeServer", "time-nw.nist.gov")
        valTimer = .Getstr("Options", "SynTimer", "1")
    End With
    With NotifyIcon
        .cbSize = Len(NotifyIcon)
        .dwInfoFlags = NIIF_INFO
        .hIcon = Me.Icon.Handle
        .hWnd = Me.hWnd
        .szInfoTitle = "同步网络时间" & vbNullChar
        .szInfo = "正在连接时间服务器,请稍候..." & vbNullChar
        .uCallBackMessage = WM_NOTIFYICON
        .uFlags = NIF_ICON Or NIF_INFO Or NIF_MESSAGE Or NIF_TIP
    End With
    Shell_NotifyIcon NIM_ADD, NotifyIcon
    pWndProc = SetWindowLong(Me.hWnd, GWL_WNDPROC, AddressOf WndProc)
    Call synchMyTime
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Shell_NotifyIcon NIM_DELETE, NotifyIcon
    SetWindowLong Me.hWnd, GWL_WNDPROC, pWndProc
    Set iniOp = Nothing
End Sub

Private Sub get_time_Timer()
    Static s_Minutes As Long
        s_Minutes = s_Minutes + 1
        If s_Minutes = valTimer Then
            s_Minutes = 0
            Call synchMyTime
        End If
End Sub

Private Sub mExit_Click()
    Unload Me
End Sub

Private Sub mOption_Click()
    frmOption.Show
End Sub

Private Sub mTimeSyn_Click()
    Call synchMyTime
End Sub

'数据到达事件
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
    Dim data As String, tmpChar$, Mydate$
    '获得服务器数据
    Winsock1.GetData data
    '判断是否同步时间
    If mblnFlag Then
        '服务器数据结构中第17,18位为小时,第20,21,22,23,24位为分钟和秒钟
        tmpChar$ = Val(Mid$(data, 17, 2) + 8)
        '同步标准时间
        Time = tmpChar$ + ":" + Mid$(data, 20, 5)
        Mydate$ = Mid$(data, 8, 8)
        Date = Mydate$
        mblnFlag = False
        NotifyIcon.szInfoTitle = "同步网络时间" & vbNullChar
        NotifyIcon.szInfo = "同步成功,服务器时间:" & Format(Mydate$, "yyyy-mm-dd") & _
            " " & tmpChar$ + ":" + Mid$(data, 20, 5) & vbNullChar
        Shell_NotifyIcon NIM_MODIFY, NotifyIcon
    End If
    '断开远程连接
    Winsock1.CloseSck
End Sub

Private Sub Winsock1_Error(ByVal Number As Integer, Description As String, ByVal sCode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
    NotifyIcon.szInfoTitle = "同步网络时间" & vbNullChar
    NotifyIcon.szInfo = "同步失败,请检查网络连接!" & vbNullChar
    Shell_NotifyIcon NIM_MODIFY, NotifyIcon
    Winsock1.CloseSck                 '关闭以前的连接
    mblnFlag = False
End Sub

Public Sub synchMyTime()
    Dim mserverName$                            '时间服务器
    mserverName = strServer            '超快响应
    If mblnFlag = False Then
        '连接服务器
        Winsock1.Connect mserverName, 13  '时间端口号为13
        mblnFlag = True
    End If
End Sub