I usually use an API timer this way. I haven't done it specifically in VBA
code, it's usually in VB 6 code, but they should be identical or almost
identical:
First, a CTimer class. Then a basTimer code module, finally code to init and
destroy the timer:
'************************************************* ***********
' CTimer class
'************************************************* ***********
Option Explicit
'************************************************* ***********
' Slovak Technical Services, Inc.
'************************************************* ***********
Private iInterval As Long
Private ID As Long
' User can attach any Variant data they want to the timer
Public Item As Variant
Public Event ThatTime()
' 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
Dim 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
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()
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
'************************************************* ***********
' End CTimer class
'************************************************* ***********
'************************************************* ***********
' basTimer code module
'************************************************* ***********
Option Explicit
'************************************************* ***********
' Slovak Technical Services, Inc.
'************************************************* ***********
' declares:
Private Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal
nIdEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal
nIdEvent As Long) As Long
Private Const cTimerMax = 100
' Array of timers
Public aTimers(1 To cTimerMax) As CTimer
' Added SPM to prevent excessive searching through aTimers array:
Private m_cTimerCount As Integer
Public Function TimerCreate(timer As CTimer) As Boolean
Dim i As Integer
On Error Resume Next
'Create the timer
timer.TimerID = SetTimer(0&, 0&, timer.Interval, AddressOf TimerProc)
If timer.TimerID Then
TimerCreate = True
For i = 1 To cTimerMax
If (aTimers(i) Is Nothing) Then
Set aTimers(i) = timer
If (i m_cTimerCount) Then
m_cTimerCount = i
End If
TimerCreate = True
Exit Function
End If
Next
timer.ErrRaise eeTooManyTimers
Else
timer.TimerID = 0
timer.Interval = 0
End If
Err.Clear
End Function
Public Function TimerDestroy(timer As CTimer) As Long
Dim i As Integer
Dim f As Boolean
On Error Resume Next
' Find and remove this timer
' SPM - no need to count past the last timer set up in the
' aTimer array:
For i = 1 To m_cTimerCount
' Find timer in array
If Not (aTimers(i) Is Nothing) Then
If timer.TimerID = aTimers(i).TimerID Then
f = KillTimer(0, timer.TimerID)
' Remove timer and set reference to nothing
Set aTimers(i) = Nothing
TimerDestroy = True
Exit Function
End If
End If
Next
Err.Clear
End Function
Public Sub TimerProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal IDEvent
As Long, ByVal dwTime As Long)
Dim i As Integer
On Error Resume Next
' Find the timer with this ID
For i = 1 To m_cTimerCount
' SPM: Add a check to ensure aTimers(i) is not nothing!
' This would occur if we had two timers declared from
' the same thread and we terminated the first one before
' the second! Causes serious GPF if we don't do this...
If Not (aTimers(i) Is Nothing) Then
If IDEvent = aTimers(i).TimerID Then
' Generate the event
aTimers(i).PulseTimer
Exit Sub
End If
End If
Next
Err.Clear
End Sub
Private Function StoreTimer(timer As CTimer)
Dim i As Integer
On Error Resume Next
For i = 1 To m_cTimerCount
If aTimers(i) Is Nothing Then
Set aTimers(i) = timer
StoreTimer = True
Exit Function
End If
Next
Err.Clear
End Function
'************************************************* ***********
' End basTimer code module
'************************************************* ***********
'************************************************* ***********
' Code to call and release a timer (in a class module to handle events)
'************************************************* ***********
Private WithEvents m_oTimer As CTimer
'******************* init timer
Set m_oTimer = New CTimer
m_oTimer.Interval = 500 ' 500 ms (1/2 minute)
'******************* timer event handler
Private Sub m_oTimer_ThatTime()
On Error Resume Next
m_oTimer.Interval = 0
' do something here
' reset timer to restart by m_oTimer.Interval = 500 for every 1/2 minute
again
End Sub
'******************** kill timer
If Not (m_oTimer Is Nothing) Then
m_oTimer.Interval = 0
Set m_oTimer = Nothing
End If
--
Ken Slovak
[MVP - Outlook]
http://www.slovaktech.com
Author: Absolute Beginner's Guide to Microsoft Office Outlook 2003
Reminder Manager, Extended Reminders, Attachment Options
http://www.slovaktech.com/products.htm
"Damon" wrote in message
...
Ken,
After reading your reply I started looking into the other suggestions you
made and I found the following example of using an API timer in VBA (it's
from C. Pearsons very helpful site for excel VBA tips.)
'''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''''''''''''
Public Declare Function SetTimer Lib "user32" ( _
ByVal HWnd As Long, ByVal nIDEvent As Long, _
ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Public Declare Function KillTimer Lib "user32" ( _
ByVal HWnd As Long, ByVal nIDEvent As Long) As Long
Public TimerID As Long
Public TimerSeconds As Single
Sub StartTimer()
TimerSeconds = 20 ' how often to "pop" the timer.
TimerID = SetTimer(0&, 0&, TimerSeconds * 1000&, AddressOf TimerProc)
End Sub
Sub EndTimer()
On Error Resume Next
KillTimer 0&, TimerID
End Sub
Sub TimerProc(ByVal HWnd As Long, ByVal uMsg As Long, _
ByVal nIDEvent As Long, ByVal dwTimer As Long)
'
' The procedure is called by Windows. Put your
' timer-related code here.
'
MsgBox "timed event" '------------------ I added this line
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''
This seemed to work great until I decided to test what would happen if the
timer was started multiple times. I was pleased to see that the message I
had triggering every 20 seconds started triggering multiple times in a 20
seconds period, However it then didn't matter how many times I ran the
EndTimer sub the TimerProc sub kept running, even if Outlook was closed
(only
managed to stop it by deleting TimerProc sub from the module and letting
Outlook crash)
Would a 3rd party timer in a userform be likely to have a similar issue or
not?
[Pre Posting Edit--- reading back this text before posting, it has
occurred
to me that the issue above may be caused because TimerID is the same for
each
case? If so how could I vary it without varying the TimerSeconds?]
So it seems I'm back to task items with reminders for the moment as I can
have multiple 'timers' set at once.
As the timer is just to send a reminder email it doesn't really need to be
at a precise time just approximately 20mins after first email if second is
not received yet. Not sure if that is what you meant by 'granularity of 1
minute'...
This bit of code...
''''''''
Private Sub Application_Reminder(ByVal Item As Object)
If Item.Subject = "Auto Recs Reminder" Then
'------------------My code here---------------
Item.Delete
End If
End Sub
''''''''
Does prevent the Reminder from showing (although you do notice it try to
show) and does, to my mild surprise, delete the TaskItem (I thought it
might
just delete the reminder attached to the task.) It does beep though so I
will
have to disable the sound when setting the reminder as you suggest.
Again thank you Ken for all your help, before your first reply I did not
even have a clue how to get started with Outlook programming (apart from
coming here to ask ;-) )