vbAccelerator - Contents of code file: cHiResTimer.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cHiResTimer"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

'
 ===============================================================================
=======
' Name:     vbAccelerator Safe Hi Resolution Timer Object (VB6 Version)
' Author:   Steve McMahon (steve@vbaccelerator.com)
' Date:     02 September 2000
'
' Requires: vbalHRTA.TLB
'           see http://vbaccelerator.com/
'
' Copyright  1999-2000 Steve McMahon for vbAccelerator
'
 -------------------------------------------------------------------------------
-------
' Visit vbAccelerator - advanced free source code for VB programmers
' http://vbaccelerator.com
'
 -------------------------------------------------------------------------------
-------
'
' A VB6 implementation of the Hi Resolution Timer object.  In VB6, the code
' doesn't respond so elegantly to the threaded implementation of a Win32 HiRes
' Timer than in VB5 - it crashed the original code.  This occurs because, as
' Matt Currland has described, in VB6 no code can be run on a new thread
' until an object has been created because of the use of TLS.
'
' In this implementation we fix the problem by only running non-VB code in
' the threaded section of the implementation, i.e. we make only API calls
 defined
' in a TLB instead.
'
'
 ===============================================================================
=======


' No need to use GetPerformanceCounter() because this
' will be accurate to the highest timer resolution:
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Private Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" ( _
    lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)

Private Type tTimerData
   lInterval As Long
   sKey As String
   bEnabled As Boolean
   lLastTick As Long
End Type
Private m_tT() As tTimerData
Private m_iCount As Long
Private m_lPtr As Long

Public Event Timer(ByVal sKey As String)

Public Sub Connect(iTmr As ITimer)
   ' Do this is you want to get an implemented
   ' call:
   m_lPtr = ObjPtr(iTmr)
End Sub

Private Property Get ObjectFromPtr(ByVal lPtr As Long) As ITimer
Dim oTHis As ITimer
    CopyMemory oTHis, lPtr, 4
    Set ObjectFromPtr = oTHis
    CopyMemory oTHis, 0&, 4
End Property

Friend Sub FireTimer()
Dim i As Long
Dim lTick As Long
Dim lAmount As Long
Dim iTmr As ITimer
   
   If m_iCount > 0 Then
      If m_lPtr <> 0 Then
         ' Using implements
         Set iTmr = ObjectFromPtr(m_lPtr)
         lTick = timeGetTime()
         For i = 1 To m_iCount
            If m_tT(i).bEnabled Then
               lAmount = (lTick - m_tT(i).lLastTick)
               If lAmount >= m_tT(i).lInterval Or lAmount < 0 Then
                  m_tT(i).lLastTick = lTick
                  iTmr.Timer m_tT(i).sKey
               End If
            End If
         Next i
      Else
         ' using events
         lTick = timeGetTime()
         For i = 1 To m_iCount
            If m_tT(i).bEnabled Then
               lAmount = (lTick - m_tT(i).lLastTick)
               If lAmount >= m_tT(i).lInterval Or lAmount < 0 Then
                  m_tT(i).lLastTick = lTick
                  RaiseEvent Timer(m_tT(i).sKey)
               End If
            End If
         Next i
      End If
   End If
End Sub

Public Property Get Count() As Long
   Count = m_iCount
End Property
Public Function Add(ByVal sKey As String, Optional ByVal lInterval As Long =
 10, Optional ByVal bEnabled As Boolean = False) As Long
   If Not (Exists(sKey)) Then
      m_iCount = m_iCount + 1
      ReDim Preserve m_tT(1 To m_iCount) As tTimerData
      With m_tT(m_iCount)
         .sKey = sKey
         .lInterval = lInterval
         .bEnabled = bEnabled
      End With
      If m_iCount = 1 Then
         StartTimer
         AddObject Me
      End If
   End If
End Function
Public Sub Remove(ByVal vKey As Variant)
Dim lIndex As Long
Dim i As Long
   lIndex = Index(vKey)
   If (lIndex > 0) Then
      If (m_iCount > 1) Then
         For i = lIndex To m_iCount - 1
            LSet m_tT(i) = m_tT(i + 1)
         Next i
         m_iCount = m_iCount - 1
         ReDim Preserve m_tT(1 To m_iCount) As tTimerData
      Else
         Erase m_tT
         m_iCount = 0
         StopTimer
         RemoveObject Me
      End If
   End If
End Sub
Public Property Get Exists(ByVal sKey As String) As Boolean
Dim i As Long
   For i = 1 To m_iCount
      If (m_tT(i).sKey = sKey) Then
         Exists = True
         Exit For
      End If
   Next i
End Property
Public Property Get Interval(ByVal vKey As Variant) As Long
Dim lIndex As Long
   lIndex = Index(vKey)
   If (lIndex > 0) Then
      Interval = m_tT(lIndex).lInterval
   End If
End Property
Public Property Let Interval(ByVal vKey As Variant, ByVal lInterval As Long)
Dim lIndex As Long
   lIndex = Index(vKey)
   If (lIndex > 0) Then
      m_tT(lIndex).lInterval = lInterval
   End If
End Property
Public Property Get Enabled(ByVal vKey As Variant) As Boolean
Dim lIndex As Long
   lIndex = Index(vKey)
   If (lIndex > 0) Then
      Enabled = m_tT(lIndex).bEnabled
   End If
End Property
Public Property Let Enabled(ByVal vKey As Variant, ByVal bEnabled As Boolean)
Dim lIndex As Long
   lIndex = Index(vKey)
   If (lIndex > 0) Then
      m_tT(lIndex).bEnabled = bEnabled
      If (bEnabled) Then
         m_tT(lIndex).lLastTick = timeGetTime()
      End If
   End If
End Property
Public Property Get Index(ByVal vKey As Variant) As Long
Dim i As Long
   If IsNumeric(vKey) Then
      If vKey > 0 And vKey <= m_iCount Then
         Index = vKey
         Exit Property
      End If
   Else
      For i = 1 To m_iCount
         If m_tT(i).sKey = vKey Then
            Index = i
            Exit Property
         End If
      Next i
   End If
   Err.Raise 9, App.EXEName & ".cHiResTimer"
End Property

Private Sub Class_Terminate()
   StopTimer
   RemoveObject Me
End Sub