vbAccelerator - Contents of code file: mHiResTimer.bas

Attribute VB_Name = "mHiResTimer"
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
'
 -------------------------------------------------------------------------------
-------
'
'
' VB6 version.  HiRes Timers run in multiple threads
' See TimerProc for the details.
'
'
 ===============================================================================
=======


Private Type TIMECAPS
   wPeriodMin As Long
   wPeriodMax As Long
End Type
Private Declare Function timeGetDevCaps Lib "winmm.dll" (lpTimeCaps As
 TIMECAPS, ByVal uSize As Long) As Long
Private Declare Function timeBeginPeriod Lib "winmm.dll" (ByVal uPeriod As
 Long) As Long
Private Declare Function timeEndPeriod Lib "winmm.dll" (ByVal uPeriod As Long)
 As Long
Private Declare Function timeSetEvent Lib "winmm.dll" (ByVal uDelay As Long,
 ByVal uResolution As Long, ByVal lpFunction As Long, ByVal dwUser As Long,
 ByVal uFlags As Long) As Long
Private Declare Function timeKillEvent Lib "winmm.dll" (ByVal uID As Long) As
 Long
Private Const TIME_ONESHOT = 0  '  program timer for single event
Private Const TIME_PERIODIC = 1  '  program for continuous periodic event
Private Const TIMERR_NOERROR = 0                        '/* no error */
Private Const WM_USER = &H400
Private Const MyTimerMessage = WM_USER + &H2867& ' =  &H2C67&
Private Const GWL_WNDPROC = (-4)
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA"
 (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA"
 (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As
 Long, ByVal lpString As String) As Long
Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As
 Long, ByVal lpString As String, ByVal hData As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA"
 (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal
 wParam As Long, ByVal lParam As Long) As Long
Private Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" ( _
    lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)

Private m_tTC As TIMECAPS
Private m_bBegin As Boolean
Private m_lID As Long
Private m_hWnd As Long
Private m_iRefCount As Long
Private m_lOldWndProc As Long

Private m_lPtr As Long

Public Sub StartTimer()
Dim lR As Long
   
   If Not m_bBegin Then
      lR = timeGetDevCaps(m_tTC, Len(m_tTC))
      If (lR = TIMERR_NOERROR) Then
         m_bBegin = True
         If CreateMessageWindow() Then
            timeBeginPeriod m_tTC.wPeriodMin
            m_lID = timeSetEvent(m_tTC.wPeriodMin, m_tTC.wPeriodMin, AddressOf
             TimerProc, m_hWnd, TIME_PERIODIC)
            If (m_lID <> 0) Then
               ' Ok!
               Exit Sub
            Else
               DestroyMessageWindow
            End If
         End If
         ' can't set timer up
         timeEndPeriod m_tTC.wPeriodMin
         m_bBegin = False
      End If
      ' can't get timer
      
   Else
      ' Timer/message window created.
      m_iRefCount = m_iRefCount + 1
   End If
   
End Sub
Public Sub AddObject(ByRef cThis As cHiResTimer)
Dim lC As Long
   lC = GetProp(m_hWnd, "vbalHiResTmr:Count")
   lC = lC + 1
   SetProp m_hWnd, "vbalHiResTmr:Count", lC
   SetProp m_hWnd, "vbalHiResTmr:Obj" & lC, ObjPtr(cThis)
   m_lPtr = ObjPtr(cThis)
End Sub
Public Sub RemoveObject(ByRef cThis As cHiResTimer)
Dim lC As Long
Dim i As Long
Dim lPtr As Long
Dim lIndex As Long

   lC = GetProp(m_hWnd, "vbalHiResTmr:Count")
   If (lC > 1) Then
      For i = 1 To lC
         lPtr = GetProp(m_hWnd, "vbalHiResTmr:Obj" & i)
         If (lPtr = ObjPtr(cThis)) Then
            lIndex = i
            Exit For
         End If
      Next i
      For i = lIndex To lC - 1
         lPtr = GetProp(m_hWnd, "vbalHiResTmr:Obj" & i + 1)
         SetProp m_hWnd, "vbalHiResTmr:Obj" & i, lPtr
      Next i
   End If
   lC = lC - 1
   SetProp m_hWnd, "vbalHiResTmr:Count", lC
   m_lPtr = 0
End Sub
Private Function CreateMessageWindow() As Boolean
   Load frmMessageWindow
   m_hWnd = frmMessageWindow.hwnd
   m_lOldWndProc = GetWindowLong(m_hWnd, GWL_WNDPROC)
   SetWindowLong frmMessageWindow.hwnd, GWL_WNDPROC, AddressOf WindowProc
   CreateMessageWindow = True
End Function
Private Sub DestroyMessageWindow()
   SetWindowLong m_hWnd, GWL_WNDPROC, m_lOldWndProc
   Unload frmMessageWindow
   m_hWnd = 0
End Sub

Public Sub StopTimer()
   m_iRefCount = m_iRefCount - 1
   If m_iRefCount < 0 Then
      m_iRefCount = 0
   End If
   If m_iRefCount = 0 Then
      DestroyMessageWindow
      If m_lID <> 0 Then
         timeKillEvent m_lID
         m_lID = 0
      End If
      If m_bBegin Then
         timeEndPeriod m_tTC.wPeriodMin
         m_bBegin = False
      End If
   End If
End Sub
Public Function TimerProc( _
      ByVal wTimerID As Long, ByVal iMsg As Long, _
      ByVal dwUser As Long, ByVal dw1 As Long, ByVal dw2 As Long _
   ) As Long
   
   ' Note 1:
   ' The only functions you are allowed to call
   ' during a High-resolution timer event are
   ' PostMessage, timeGetSystemTime, timeGetTime,
   ' timeSetEvent, timeKillEvent,
   ' midiOutShortMsg, midiOutLongMsg,
   ' and OutputDebugString.
   
   ' Therefore here we are posting the message to a window.
   ' Incidentally this also helps us with the next problem too:
   ' how to get information from another thread marshalled onto
   ' our own thread.
   
   ' Note 2:
   ' This function can get called from another thread than the main
   ' VB one.  As Matt Currland has demonstrated, the use of TLS means
   ' you cannot run any VB code in a new thread unless the first object
   ' has been created on it.  This means the only code we are allowed
   ' to call in there is a API call which is defined in a Type Library!
   '
   
   ' dwUser is set to the window of our hidden window,
   ' &H2C67& is the MyTimerMessage constant, hardcoded here
   ' jic that causes VB code to run :)
   PostMessage dwUser, &H2C67&, 0, 0
   
End Function
Public Function WindowProc( _
      ByVal hwnd As Long, ByVal iMsg As Long, _
      ByVal wParam As Long, ByVal lParam As Long _
   ) As Long
Dim lC As Long
Dim i As Long
Dim cHRT As cHiResTimer
Dim lPtr As Long

   If iMsg = MyTimerMessage Then
      lC = GetProp(m_hWnd, "vbalHiResTmr:Count")
      For i = 1 To lC
         lPtr = GetProp(m_hWnd, "vbalHiResTmr:Obj" & i)
         If (lPtr <> 0) Then
            Set cHRT = ObjectFromPtr(lPtr)
            cHRT.FireTimer
         End If
      Next i
   Else
      CallWindowProc m_lOldWndProc, hwnd, iMsg, wParam, lParam
   End If
   
End Function

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