Les,
Try this.
In my example, the message is started by one button and stopped by another,
you will need to adapt to your situation.
This goes in a standard code module
Option Explicit
Option Private Module
'-----------------------------------------------------------------
' Application Constants
'-----------------------------------------------------------------
Public Const AppId As String = "xldTimer"
Public Const AppTitle As String = "xld Timer Add-In"
Public Const AppHead As String = "xld Timer"
Public Const AppMenu As String = "xld Ti&mer"
Public nTimeEnd As Double
'-----------------------------------------------------------------
' Win32 APIs
'-----------------------------------------------------------------
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
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 WindowsTimer As Long
'-----------------------------------------------------------------
Public Sub StartTimer()
'-----------------------------------------------------------------
fncWindowsTimer 333, WindowsTimer '1/3 sec
End Sub
'-----------------------------------------------------------------
Public Sub StopTimer()
'-----------------------------------------------------------------
fncStopWindowsTimer
End Sub
'-----------------------------------------------------------------
Public Function cbkRoutine(ByVal Window_hWnd As Long, _
ByVal WindowsMessage As Long, _
ByVal EventID As Long, _
ByVal SystemTime As Long) As Long
'-----------------------------------------------------------------
Dim CurrentTime As String
On Error Resume Next
UpdateForm
End Function
'-----------------------------------------------------------------
Public Function fncStopWindowsTimer()
'-----------------------------------------------------------------
KillTimer hWnd:=FindWindow("XLMAIN", Application.Caption), _
nIDEvent:=0 'WindowsTimer
End Function
'-----------------------------------------------------------------
Public Function fncWindowsTimer(TimeInterval As Long, _
WindowsTimer As Long) As Boolean
'-----------------------------------------------------------------
WindowsTimer = 0
WindowsTimer = SetTimer(hWnd:=FindWindow("XLMAIN", Application.Caption),
_
nIDEvent:=0, _
uElapse:=TimeInterval, _
lpTimerFunc:=AddressOf UpdateForm)
fncWindowsTimer = CBool(WindowsTimer)
DoEvents
End Function
'-----------------------------------------------------------------
Public Function UpdateForm()
'-----------------------------------------------------------------
Static FlipFlop As Boolean
With Userform2.Label1
.Font.Name = "Arial"
.Font.Size = 14
.Font.Bold = True
.WordWrap = True
FlipFlop = Not FlipFlop
If FlipFlop Then
.Caption = "ERROR"
.BackColor = RGB(253, 7, 100)
Else
.Caption = ""
.BackColor = RGB(255, 255, 255)
End If
End With
End Function
and this goes on the form
Option Explicit
Private mStopTime As Double
Private Sub cmdQuit_Click()
StopTimer
Unload Me
End Sub
Private Sub cmdStart_Click()
StartTimer
End Sub
Private Sub cmdStop_Click()
StopTimer
End Sub
Private Sub UserForm_Initialize()
mStopTime = 0
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
StopTimer
End Sub
--
---
HTH
Bob
(there's no email, no snail mail, but somewhere should be gmail in my addy)
