fireoncetimers.bas

VB圣经

Attribute VB_Name = "FireOnceTimers"
'***************************************************************
' (c) Copyright 2000 Matthew J. Curland
'
' This file is from the CD-ROM accompanying the book:
' Advanced Visual Basic 6: Power Techniques for Everyday Programs
'   Author: Matthew Curland
'   Published by: Addison-Wesley, July 2000
'   ISBN: 0-201-70712-8
'   http://www.PowerVB.com
'
' You are entitled to license free distribution of any application
'   that uses this file if you own a copy of the book, or if you
'   have obtained the file from a source approved by the author. You
'   may redistribute this file only with express written permission
'   of the author.
'
' This file depends on:
'   References:
'     VBoostTypes6.olb (VBoost Object Types (6.0))
'   Files:
'     FireTimer.cls
'   Minimal VBoost conditionals:
'     None
'   Conditional Compilation Values:
'     None
'
' This file is discussed in Chapter 13.
'***************************************************************

'This enables you to easily start asynchronous calls
'on threads.  Simply Implement the FireTimer class.
'In a call to do a long operation, store the incoming
'data and call 'AddTimer Me'

Option Explicit

Private m_FireOnceTimers As New VBA.Collection

Function AddTimer(ByVal FOT As FireTimer) As Long
    'Create a new timer object
    AddTimer = SetTimer(0, 0, 1, AddressOf TimerProc)
    If AddTimer Then
        'If successful, then add the object to a collection as
        'a weak reference.  This means that if something happens
        'which kills the class before the Timer fires, then this
        'won't artificially keep the class instance alive.  The
        'downside is that the class must call ClearTimer explicitly
        'on shutdown if FireTimer_Go has not been called yet.
        'FireTimer_Go should always clear this value.
        m_FireOnceTimers.Add ObjPtr(FOT), CStr(AddTimer)
    End If
End Function
Public Sub ClearTimer(ByVal TimerID As Long)
    On Error Resume Next
    m_FireOnceTimers.Remove CStr(TimerID)
    If Err Then
        Err.Clear
    Else
        KillTimer 0, TimerID
    End If
End Sub
Private Sub TimerProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long)
Dim Fire As FireTimer
Dim FireRefed As FireTimer
Dim pFire As Long
Dim strKey As String
    On Error Resume Next
    strKey = CStr(idEvent)
    pFire = m_FireOnceTimers(strKey)
    If pFire Then
        'Get the weak reference out of the collection object,
        'make sure it gets a properly counted reference, clean
        'up the collection and timer, then call Go.
        CopyMemory Fire, pFire, 4
        Set FireRefed = Fire
        CopyMemory Fire, 0&, 4
        m_FireOnceTimers.Remove strKey
        KillTimer 0, idEvent
        FireRefed.Go
    End If
End Sub