timer.cls

漂亮的VB版本的界面,界面可以进行扩展并且所需要的代码又非常的少。是一个优秀的原码你可以下载学习之用。

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CTimer"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
' ==================================================================================================
' 源程序由 http://vbaccelerator.com 提供(并有DLL库文件)。但由于有一些BUG，导致程序无法正常运行。
'
' 所以，我(天生三排牙，Mail：[e-mail])将它重新整理了一下，并写成了新的DLL库。
'
' 但是，BUG在所难免，所以，请使用的各位小虾、大侠们多提提意见，我也会在有空的时候再修改这个程序的。
'
' 当然，源程序以及DLL库都是免费的，你可以在任何地方使用。但请适当保留原作者信息，以示对原作者的尊重。
'
' 如果你对该程序进行了修改，增加了新的功能，希望能Mail一份给我，让我也分享你的喜悦。谢谢！
' ==================================================================================================

Option Explicit
Private iInterval As Long
Private id As Long

' User can attach any Variant data they want to the timer
Public Item As Variant
Attribute Item.VB_VarDescription = "Gets/sets a piece of additional data to store with the timer."

Public Event ThatTime()
Attribute ThatTime.VB_Description = "Raised when the timer fires."

' SubTimer is independent of VBCore, so it hard codes error handling

Public Enum EErrorTimer
    eeBaseTimer = 13650     ' CTimer
    eeTooManyTimers         ' No more than 10 timers allowed per class
    eeCantCreateTimer       ' Can't create system timer
End Enum
'===================================================
'
'===================================================
Friend Sub ErrRaise(e As Long)
    Dim sText As String, sSource As String
    If e > 1000 Then
        sSource = App.EXEName & ".WindowProc"
        Select Case e
        Case eeTooManyTimers
            sText = "No more than 10 timers allowed per class"
        Case eeCantCreateTimer
            sText = "Can't create system timer"
        End Select
        Err.Raise e Or vbObjectError, sSource, sText
    Else
        ' Raise standard Visual Basic error
        Err.Raise e, sSource
    End If
End Sub
'===================================================
'
'===================================================
Property Get Interval() As Long
Attribute Interval.VB_Description = "Gets/sets the interval at which the timer fires.  Set to zero to stop the timer."
    Interval = iInterval
End Property

' Can't just change interval--you must kill timer and start a new one
Property Let Interval(iIntervalA As Long)
    Dim f As Boolean
    If iIntervalA > 0 Then
        ' Don't mess with it if interval is the same
        If iInterval = iIntervalA Then Exit Property
        ' Must destroy any existing timer to change interval
        If iInterval Then
            f = TimerDestroy(Me)
            Debug.Assert f      ' Shouldn't fail
        End If
        ' Create new timer with new interval
        iInterval = iIntervalA
        If TimerCreate(Me) = False Then ErrRaise eeCantCreateTimer
    Else
        If (iInterval > 0) Then
            iInterval = 0
            f = TimerDestroy(Me)
            Debug.Assert f      ' Shouldn't fail
        End If
    End If
End Property

' Must be public so that Timer object can't terminate while client's ThatTime
' event is being processed--Friend wouldn't prevent this disaster
'===================================================
'
'===================================================
Public Sub PulseTimer()
Attribute PulseTimer.VB_MemberFlags = "40"
    RaiseEvent ThatTime
End Sub
'===================================================
'
'===================================================
Friend Property Get TimerID() As Long
    TimerID = id
End Property
'===================================================
'
'===================================================
Friend Property Let TimerID(idA As Long)
    id = idA
End Property
'===================================================
'
'===================================================
Private Sub Class_Terminate()
    Interval = 0
End Sub