datetimemain.frm

个人VB学习源码精选,自己学习时的一些编程小程序,希望对大家有帮助

VERSION 5.00
Begin VB.Form DateTimeMain 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "Date Project"
   ClientHeight    =   7770
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   6615
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   7770
   ScaleWidth      =   6615
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  '屏幕中心
   Begin VB.TextBox txtThen 
      Height          =   375
      Left            =   120
      TabIndex        =   11
      Top             =   7320
      Width           =   5895
   End
   Begin VB.Timer tmrMouse 
      Interval        =   2500
      Left            =   5160
      Top             =   720
   End
   Begin VB.Timer tmrClock 
      Interval        =   250
      Left            =   4680
      Top             =   720
   End
   Begin VB.CommandButton cmdExit 
      Caption         =   "E&xit"
      Height          =   375
      Left            =   4920
      TabIndex        =   10
      Top             =   5160
      Width           =   1095
   End
   Begin VB.CommandButton cmdSet 
      Caption         =   "&Set System"
      Height          =   375
      Left            =   4920
      TabIndex        =   9
      Top             =   4320
      Width           =   1095
   End
   Begin VB.CommandButton cmdCalculate 
      Caption         =   "&Calculate"
      Default         =   -1  'True
      Height          =   375
      Left            =   4920
      TabIndex        =   8
      Top             =   3480
      Width           =   1095
   End
   Begin VB.PictureBox picTheWindsOfTime 
      Height          =   4575
      Left            =   113
      Picture         =   "DateTimeMain.frx":0000
      ScaleHeight     =   4515
      ScaleWidth      =   4035
      TabIndex        =   7
      Top             =   2640
      Width           =   4095
   End
   Begin VB.Label lblMrMouse 
      Height          =   495
      Left            =   120
      TabIndex        =   6
      Top             =   2040
      Width           =   4695
   End
   Begin VB.Label lblDifference 
      Height          =   615
      Left            =   120
      TabIndex        =   5
      Top             =   1200
      Width           =   4575
   End
   Begin VB.Label lblSerial 
      Height          =   375
      Left            =   2040
      TabIndex        =   4
      Top             =   600
      Width           =   1575
   End
   Begin VB.Label lblNow 
      Height          =   375
      Left            =   120
      TabIndex        =   3
      Top             =   600
      Width           =   1575
   End
   Begin VB.Label lblStopWatch 
      BackColor       =   &H00000000&
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   18
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H0000C000&
      Height          =   375
      Left            =   4200
      TabIndex        =   2
      Top             =   120
      Width           =   1455
   End
   Begin VB.Label Label2 
      Caption         =   "Now (Serial)"
      Height          =   255
      Left            =   2040
      TabIndex        =   1
      Top             =   120
      Width           =   1575
   End
   Begin VB.Label Label1 
      Caption         =   "Now (String)"
      Height          =   255
      Left            =   120
      TabIndex        =   0
      Top             =   120
      Width           =   1095
   End
End
Attribute VB_Name = "DateTimeMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Const conAppTime = "Date/Time Project"
Private Const conSetSystem = "&Set System"
Private Const conResetSystem = "&Reset System"

Private Sub cmdCalculate_Click()
    Dim dtmThen As Date, dtmNow As Date
    Dim strYear As String, strMonth As String, strDay As String
    Dim strWeekDay As String, strMessage As String
    
    On Error GoTo Baddate
    dtmThen = CDate(txtThen.Text)
    On Error GoTo 0
    
    dtmNow = Now
    strYear = Str$(Year(dtmThen) - Year(dtmNow))
    strMonth = Str$(Month(dtmThen) - Month(dtmNow))
    strDay = Str$(Day(dtmThen) - Day(dtmNow))
    
    strWeekDay = Format(dtmThen, "dddd")
    strMessage = strYear & "years," & strMonth & "months," & strDay & "days;" & Chr$(10)
    strMessage = strMessage & "The day of the week you gave is a " & strWeekDay & "."
    lblDifference.Caption = strMessage
    Exit Sub
    
Baddate:
    ErrMsgBox "Please type a date in the correct format."
    txtThen.SetFocus
    Exit Sub
End Sub

Private Sub cmdExit_Click()
    Unload Me
End Sub

Private Sub cmdSet_Click()
    Static dtmOldSystem As Date, dtmOffset As Date
    Dim dtmSetSystem As Date
    
    Select Case cmdSet.Caption
        Case conSetSystem
            dtmOldSystem = Now
            On Error GoTo BadSetDateTime
            dtmSetSystem = CDate(txtThen.Text)
            Date = dtmSetSystem
            Time = dtmSetSystem
            On Error GoTo 0
            cmdSet.Caption = conResetSystem
        Case conResetSystem
            dtmSetSystem = dtmOldSystem + Now - dtmOffset
            Date = dtmSetSystem
            Time = dtmSetSystem
            cmdSet.Caption = conSetSystem
    End Select
    dtmOffset = Now
    ShowCurrentDateTime
    Exit Sub
BadSetDateTime:
    ErrMsgBox "Please type a date or time in the correct format. "
    txtThen.SetFocus
    Exit Sub
        
End Sub

Private Sub Form_Load()
    ShowCurrentDateTime
    
    txtThen.Text = "Type a date or time in me !"
    lblMrMouse.Caption = "I display the mouse position " & "as a date(x) and time(y)"
    picTheWindsOfTime.Scale (0, 0)-(1, 1)
    picTheWindsOfTime.Print
    picTheWindsOfTime.Print "   Click Me!"
    tmrClock.Tag = Str(Timer)
End Sub

Private Sub Form_Unload(Cancel As Integer)
    If cmdSet.Caption = conResetSystem Then
       cmdSet_Click
    End If
End Sub

Private Sub picTheWindsOfTime_Click()
    tmrMouse.Enabled = True
End Sub

Private Sub picTheWindsOfTime_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim yr As Integer, mt As Integer, dy As Integer
    Dim hr As Integer, mn As Integer, sc As Integer
    Dim mouseTime As Date
    
    If tmrMouse.Enabled = False Then
        yr = 1997
        mt = Int(X * 12)
        dy = Int(X * 365)
        hr = Int(Y * 24)
        mn = Int(Y * 60 * 24) Mod 60
        sc = Int(Y * 60 * 24 * 24) Mod 60
        mouseTime = DateSerial(yr, mt, dy) + TimeSerial(hr, mn, sc)
        lblMrMouse.Caption = Format$(mouseTime, "dd,mmmmm d,yyyy  h:mm:ss am/pm")
    End If
End Sub

Private Sub tmrClock_Timer()
    Dim sngStartTime As Single, sngElapsed As Single
    
    '****这里将Timer函数的秒数转为分秒格式的方法很好****
    sngStartTime = tmrClock.Tag
    sngElapsed = Timer - sngStartTime
    sngElapsed = (sngElapsed \ 60) * 100 + sngElapsed Mod 60
    lblStopWatch = Format(sngElapsed, "00:00")
    
    ShowCurrentDateTime
End Sub

Private Sub tmrMouse_Timer()
    tmrMouse.Enabled = False
End Sub

Private Sub txtThen_GotFocus()
    txtThen.SelStart = 0
    txtThen.SelLength = Len(txtThen.Text)
End Sub

Private Sub ShowCurrentDateTime()
    lblNow.Caption = Date
    lblSerial = Format(Now, "###,##0")
End Sub

Private Sub ErrMsgBox(strMessage As String)
    MsgBox strmessag, vbOKOnly + vbCritical, conApptitle
End Sub