明晨网络

    通常在VB窗体中拖入一个Timer控件来实现定时功能，但在类模块 或者ACTIVEX DLL中如何定时呢？明晨网络Mingchennet.com从国外收集到一段代码，包括一个bas模块和cls类模块，没有窗体也能使用定时器了。

bas模块modXTimerSupport

 

Option Explicit  
     
     
Const MAXTIMERINCREMEMT = 5  
     
     
Private Type XTIMERINFO  
    xt As clsXTimer  
    id As Long 
    blnReentered As Boolean 
End Type  
     
     
Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerProc As Long) As Long 
Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long 
     
     
Private maxti() As XTIMERINFO  
     
     
Private mintMaxTimers As Integer 
   
   
Public Function BeginTimer(ByVal xt As clsXTimer, ByVal Interval As Long)  
    Dim lngTimerID As Long 
    Dim intTimerNumber As Integer 
     
    lngTimerID = SetTimer(0, 0, Interval, AddressOf TimerProc)  
    If lngTimerID = 0 Then Err.Raise vbObjectError + 31013, , "没有可用的定时器" 
     
    For intTimerNumber = 1 To mintMaxTimers  
        If maxti(intTimerNumber).id = 0 Then Exit For 
    Next 
     
    If intTimerNumber > mintMaxTimers Then 
        mintMaxTimers = mintMaxTimers + MAXTIMERINCREMEMT  
        ReDim Preserve maxti(1 To mintMaxTimers)  
    End If 
     
    Set maxti(intTimerNumber).xt = xt  
     
    maxti(intTimerNumber).id = lngTimerID  
    maxti(intTimerNumber).blnReentered = False 
    BeginTimer = lngTimerID  
End Function 
   
   
Public Sub TimerProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal lngSysTime As Long)  
    Dim intCt As Integer 
     
     
    For intCt = 1 To mintMaxTimers  
        If maxti(intCt).id = idEvent Then 
            If maxti(intCt).blnReentered Then Exit Sub 
            maxti(intCt).blnReentered = True 
            On Error Resume Next 
            maxti(intCt).xt.RaiseTick  
            If Err.Number <> 0 Then 
                KillTimer 0, idEvent  
                maxti(intCt).id = 0  
                Set maxti(intCt).xt = Nothing 
            End If 
            maxti(intCt).blnReentered = False 
            Exit Sub 
        End If 
    Next 
    KillTimer 0, idEvent  
End Sub 
   
   
Public Sub EndTimer(ByVal xt As clsXTimer)  
    Dim lngTimerID As Long 
    Dim intCt As Integer 
     
    lngTimerID = xt.TimerID  
    If lngTimerID = 0 Then Exit Sub 
    For intCt = 1 To mintMaxTimers  
        If maxti(intCt).id = lngTimerID Then 
            KillTimer 0, lngTimerID  
            Set maxti(intCt).xt = Nothing 
            maxti(intCt).id = 0  
            Exit Sub 
        End If 
    Next 
End Sub 
   
   
Public Sub Scrub()  
    Dim intCt As Integer 
    For intCt = 1 To mintMaxTimers  
        If maxti(intCt).id <> 0 Then KillTimer 0, maxti(intCt).id  
    Next 
End Sub 

cls类模块clsXTimer

 

Option Explicit  
     
     
Private mlngTimerID As Long 
Private mlngInterval As Long 
Private mblnEnabled As Boolean 
     
     
Event Tick()  
   
   
Friend Property Get TimerID() As Long 
    TimerID = mlngTimerID  
End Property 
   
   
Public Property Get Enabled() As Boolean 
    Enabled = mblnEnabled  
End Property 
   
   
Public Property Let Enabled(ByVal NewValue As Boolean)  
    If NewValue = mblnEnabled Then Exit Property 
    mblnEnabled = NewValue  
    If mlngInterval = 0 Then Exit Property 
    If mblnEnabled Then 
        Debug.Assert mlngTimerID = 0  
        mlngTimerID = BeginTimer(Me, mlngInterval)  
    Else 
        If mlngTimerID <> 0 Then 
            Call EndTimer(Me)  
            mlngTimerID = 0  
        End If 
    End If 
End Property 
   
   
Public Property Get Interval() As Long 
    Interval = mlngInterval  
End Property 
   
   
Public Property Let Interval(ByVal NewInterval As Long)  
    If NewInterval = mlngInterval Then Exit Property 
    mlngInterval = NewInterval  
    If mlngTimerID <> 0 Then 
        Call EndTimer(Me)  
        mlngTimerID = 0  
    End If 
    If (NewInterval <> 0) And mblnEnabled Then 
        mlngTimerID = BeginTimer(Me, NewInterval)  
    End If 
End Property 
   
   
Public Sub RaiseTick()  
    RaiseEvent Tick  
End Sub 
   
   
Private Sub Class_Terminate()  
    On Error Resume Next 
    If mlngTimerID <> 0 Then KillTimer 0, mlngTimerID  
     
     
End Sub 

文章源自:明晨网络，admin，《VB代码：可在非窗体模块中使用的定时器》，http://www.mingchennet.com/tec/code/vb/30.htm