A timer displays the time of day in a status bar.
This is what it looks like(using the form from here plus 3 additional command buttons):
First the version without handle.
Add following code to an empty Userform 'frmSB_Demo':
Option Explicit
Private Sub btnExit_Click()
modTimer.StopTimer
Me.Hide
Unload Me
End Sub
Private Sub btnStart_Click()
modTimer.StartTimer
End Sub
Private Sub btnStop_Click()
modTimer.StopTimer
End Sub
Private Sub UserForm_Initialize()
SetControlPos
End Sub
Sub SetControlPos()
Dim L As Single
Dim T As Single
Dim W As Single
Dim Wi As Single
Dim Hi As Single
Dim SBHeight As Single
Wi = Me.InsideWidth
Hi = Me.InsideHeight
SBHeight = lblSB1.Height
L = 0
T = Hi - SBHeight
W = 160
lblSB1.Move L, T, W
L = W
W = 32
lblSB2.Move L, T, W
L = lblSB1.Width + W
W = Wi - lblSB1.Width - W
lblSB3.Move L, T, W
L = 3
T = Hi - btnStart.Height - lblSB1.Height - 3
btnStart.Move L, T
L = btnStart.Left + btnStart.Width + 3
btnStop.Move L, T
L = Wi - btnExit.Width - 3
btnExit.Move L, T
End Sub
Sub SetSBText(strText As String, iPanel As Integer)
Select Case iPanel
Case 0
lblSB1.Caption = strText
Case 1
lblSB2.Caption = strText
Case 2
lblSB3.Caption = strText
Case Else
MsgBox "Can't write text!", vbOKOnly, "SetSBText"
End Select
End Sub
Add this code to an empty module 'modTimer':
Option Explicit
Private Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
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 Declare Sub GetSystemTime Lib "kernel32" (lpSystemTime As SYSTEMTIME)
Public iTimer As Integer 'the timer identifier
Private Const lDelay As Long = 1000 'the time in ms between WM_TIMER events
Public Function TimerProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal iTimerID As Long, ByVal dwTime As Long) As Long
Dim st As SYSTEMTIME
GetLocalTime st
frmSB_Demo.SetSBText Format$(st.wHour, "00") & ":" & Format$(st.wMinute, "00") & ":" & Format$(st.wSecond, "00"), 2
End Function
Sub CATMain()
Load frmSB_Demo
frmSB_Demo.Show
End Sub
Public Sub StartTimer()
iTimer = SetTimer(0&, 0&, lDelay, AddressOf TimerProc) 'start timer
If iTimer <> 0 Then 'is there a timer
frmSB_Demo.SetSBText "Timer started", 0
Else 'if no timer exists
MsgBox "Couldn't create timer. Exiting...", _
vbOKOnly Or vbCritical, "StartTimer" 'send message
End 'exit macro
End If
End Sub
Public Sub StopTimer()
KillTimer 0&, iTimer
frmSB_Demo.SetSBText "Timer stopped", 0
End Sub
Now the version with handle.
The code of the form is the same as above.
The module code changes a bit:
Option Explicit
Private Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
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 Declare Sub GetSystemTime Lib "kernel32" (lpSystemTime As SYSTEMTIME)
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Const ID_TIMER1 = 1 'the timer identifier
Private UF_hWnd As Long
Private Const lDelay As Long = 1000 'the time in ms between WM_TIMER events
Public Function TimerProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal iTimerID As Long, ByVal dwTime As Long) As Long
Dim st As SYSTEMTIME
GetLocalTime st
frmSB_Demo.SetSBText Format$(st.wHour, "00") & ":" & Format$(st.wMinute, "00") & ":" & Format$(st.wSecond, "00"), 2
End Function
Sub CATMain()
Load frmSB_Demo
frmSB_Demo.Show
End Sub
Public Sub StartTimer()
Dim iTimer As Integer
UF_hWnd = FindWindow("ThunderDFrame", frmSB_Demo.Caption)
iTimer = SetTimer(UF_hWnd, ID_TIMER1, lDelay, AddressOf TimerProc) 'start timer
If iTimer <> 0 Then 'is there a timer
frmSB_Demo.SetSBText "Timer started", 0
Else 'if no timer exists
MsgBox "Couldn't create timer. Exiting...", _
vbOKOnly Or vbCritical, "StartTimer" 'send message
End 'exit macro
End If
End Sub
Public Sub StopTimer()
KillTimer UF_hWnd, ID_TIMER1
frmSB_Demo.SetSBText "Timer stopped", 0
End Sub
Clicking the 'Start' button activates the timer; the current time is displayed in the right panel of the status bar.
Clicking 'Stop' halts the timer; the current time displayed is not further updated.
'Exit' ends the macro. As a precautionary measure, a potentially running timer is stopped.
There is still one flaw in the code:
The possibility to end the macro by clicking on the 'x' in the caption bar.
There are two remedies to this issue:
- change the System menu, as shown here
- use the QueryClose or Terminate Event, e.g.:
Private Sub UserForm_Terminate()
btnExit_Click
End Sub
This will prevent any running timers from slipping through the cracks.
The version without handle needs to be changed as well.