## Motivation
Windows API timers are notorious for crashing.
I've been using them for years to workaround a nasty bug that makes User Defined Functions (UDFs) very slow in Excel when calculated in Automatic mode. For a couple of years I've been using Windows API timers to interrupt calculation and then calculate everything in Manual calculation mode. Here is the current GitHub [commit](https://github.com/cristianbuse/VBA-FastExcelUDFs/tree/a196f1bf830d4e9e6fb0a14cdd81462bffcc0433).
Timers were quite bad in Office 32-bit as they crashed quite often, especially if state was lost.
In 64-bit they seem even worse as a simple code break will crash Excel. Or, if the application is too busy, the timers will simply crash it. I needed a replacement solution.
I've considered stuff like:
- ```Application.OnTime``` which does not work unfortunately when called from a UDF context and fails when debugging and in a few other niche scenarios
- Using sheet calculate events is useless as I do not want to wait for the calculations to run
- Using a custom RibbonUI object to trigger callbacks works somewhat but only if the ribbon has fully loaded. It also adds the extra hassle of managing the internal XML refs and is not easily portable
But none were useful.
## What is already available
[@Greedo](https://codereview.stackexchange.com/users/146810/greedo) has done an excellent job in documenting WIN API timers [here](https://github.com/Greedquest/VBA-Timing-Methods) and even posted [this framework](https://codereview.stackexchange.com/questions/229656/tick-tick-breathe-boom-setting-up-real-stable-asynchronous-callbacks-wit) which provides nice wrappers. Unfortunately, this is still crashing.
Then there is stuff like [this](https://github.com/thetrik/VbTrickTimer). Looks cool for someone like me who does not understand assembly but it does not work at all on any of my 32 or 64-bit Office 365. Not even one 'tick' event is raised.
There are also countless other posts on the web using either Win API timers or ```Application.OnTime``` but none solve my issue.
## Solution
In truth, I did not even need timers. I only needed something like ```Application.OnTime``` but more reliable.
Regardless, I ended up with 2 solutions, both using a second Excel instance:
1. Wrapped Win API timers - works on Windows only
2. Plain Excel functionality - works on Win and Mac but does not work when Excel has a modal window on or while editing formulas
I started a new GitHub repository for this: [Excel-VBA-SafeTimers](https://github.com/cristianbuse/Excel-VBA-SafeTimers) which already contains the first solution.
I will present the first solution here but I will post the second solution to the repository at a later stage.
**Win API solution**
The solution only involves one class module and one standard module:
- ```LibTimers.bas```
- ```SafeDispatch.cls```
The ```LibTimers``` module exposes wrappers for [SetTimer](https://docs.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-settimer) and [KillTimer](https://docs.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-killtimer) which match the exact function signatures as the Windows counterparts. This makes it easy to update existing projects to use this library.
When called for the first time the ```SetTimer``` wrapper initializes the second application instance. Alternatively, there is an ```InitTimers``` method that can be called at any time e.g. at ```Workbook_Open```.
When the second instance of Excel is created there are 2 possible cases:
1. A book is created and saved as an add-in. All the code needed is placed at the bottom of the ```LibTimers``` module as string so that users have full visibility of the entire code. This works **even if there is no trusted access to the VB Object Model** - see the private ```CreateBookInRemoteApp``` method
2. The book/add-in already exists and so it is simply opened in the remote app instance. If multiple books within the current application instance are using timers, then the same remote app instance will be used for all of them. The remote code is 'smart' enough to manage multiple workbooks. Also, the local code can find the remote instance if it's already running.
That second instance runs a continuos loop which [posts](https://docs.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-postmessagea) messages back to the initial application instance.
There is only one 'real' main timer callback (```TimerProc```) per workbook and it's the only one affected by the posted messages from the remote app. When called, it safely [dispatches](https://docs.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-dispatchmessage) messages to the relevant procedures (timer procs). No timers are left hanging. Even if state is lost, the remote app will make sure to call the book timer so that it can remove itself.
The remote application is automatically terminated when there are no more books left to manage i.e. the current application was closed.
Safety features:
- Timers are removed from the remote app when state is lost. Also the 'main' timer is killed in the receiving app
- Timers are not called when the receiving application is busy or code is in break mode. This allows safe debugging. For this, a child window of the ```Locals``` window is regularly queried remotely
- ```SafeDispatch.cls``` was added to avoid crashes when the 'Stop' button is pressed (or ```End``` is called) in the timer callbacks especially for 32-bit Excel. Did not seem to be needed on 64-bit
- No new timer message is posted until the previous one was dispatched even if multiple books are using the remote app
Although I've put a lot of thought into this, there are still a few edge cases where the application can crash but really easy to avoid as they involve intentional interaction:
1. On 32-bit Excel, if the 'Stop' button is pressed inside the private ```TimerProc``` inside the ```LibTimers``` module. However, 'Stop' can be pressed with no issue inside the receiving timer procs which are the actual callbacks used. This does not affect real use
2. When the timer callback passed to ```SetTimer``` as the ```lpTimerFunc``` is not valid. This can happen if:
- ```AddressOf``` was not used i.e. a bad function pointer was passed
- The callback becomes unavailable i.e. the method is removed by being deleted or commented. This also is not an issue in real use
There may be other niche cases but in the testing that I've done, the solution was completely stable.
The solution does not use any external dependencies. Only API calls.
The remote application instance is efficient through the use of the [Sleep](https://docs.microsoft.com/en-us/windows/win32/api/synchapi/nf-synchapi-sleep) API. After the initial startup, the CPU drops to less than 0.5% on my x64 Excel and less than 1% on x32.
**Implementation**
```LibTimers``` standard module:
```VBA
'''=============================================================================
''' Excel-VBA-SafeTimers
''' ----------------------------------------------------
''' https://github.com/cristianbuse/Excel-VBA-SafeTimers
''' ----------------------------------------------------
''' MIT License
'''
''' Copyright (c) 2022 Ion Cristian Buse
'''
''' Permission is hereby granted, free of charge, to any person obtaining a copy
''' of this software and associated documentation files (the "Software"), to
''' deal in the Software without restriction, including without limitation the
''' rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
''' sell copies of the Software, and to permit persons to whom the Software is
''' furnished to do so, subject to the following conditions:
'''
''' The above copyright notice and this permission notice shall be included in
''' all copies or substantial portions of the Software.
'''
''' THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
''' IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
''' FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
''' AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
''' LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
''' FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
''' IN THE SOFTWARE.
'''=============================================================================
Option Explicit
Option Private Module
#If VBA7 = 0 Then 'LongPtr trick discovered by @Greedo (https://github.com/Greedquest)
Public Enum LongPtr
[_]
End Enum 'Kindly given here:
#End If 'https://github.com/cristianbuse/VBA-MemoryTools/issues/3
Private Type GUID
data1 As Long
data2 As Integer
data3 As Integer
data4(0 To 7) As Byte
End Type
#If VBA7 Then
Private Declare PtrSafe Function AccessibleObjectFromWindow Lib "oleacc" (ByVal hWnd As LongPtr, ByVal dwId As Long, riid As GUID, ppvObject As Object) As Long
Private Declare PtrSafe Function EnumThreadWindows Lib "user32" (ByVal dwThreadId As Long, ByVal lpfn As LongPtr, ByVal lParam As LongPtr) As Long
Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare PtrSafe Function KillTimerAPI Lib "user32" Alias "KillTimer" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
Private Declare PtrSafe Function SetTimerAPI Lib "user32" Alias "SetTimer" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
#Else
Private Declare Function AccessibleObjectFromWindow Lib "oleacc" (ByVal hWnd As Long, ByVal dwId As Long, riid As GUID, ppvObject As Object) As Long
Private Declare Function EnumThreadWindows Lib "user32" (ByVal dwThreadId As Long, ByVal lpfn As Long, ByVal lParam As Long) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare Function KillTimerAPI Lib "user32" Alias "KillTimer" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Function SetTimerAPI Lib "user32" Alias "SetTimer" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
#End If
Const USER_TIMER_MAXIMUM As Long = &H7FFFFFFF 'Around 25 days
Private Const BOOK_NAME As String = "RemoteTimersAPI_V1.xlam"
Private m_localTimers As Collection
Private m_remoteTimers As Object
Private m_VBIDEHWnd As LongPtr
Private m_bookID As String
'*******************************************************************************
'An enhanced 'Now' - returns the date and time including milliseconds
'*******************************************************************************
Public Function NowMs() As Date
Const secondsPerDay As Long = 24& * 60& * 60&
NowMs = Date + Round(Timer, 3) / secondsPerDay
End Function
'*******************************************************************************
'Safe wrapper around Win API
'https://docs.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-settimer
'Parameters:
' - hWnd: a handle to the window to be associated with the timer
' - nIDEvent: a nonzero timer identifier
' - uElapse: the time-out value, in milliseconds
' - lpTimerFunc: a pointer to the function to be notified
'*******************************************************************************
Public Function SetTimer(ByVal hWnd As LongPtr _
, ByVal nIDEvent As LongPtr _
, ByVal uElapse As Long _
, ByVal lpTimerFunc As LongPtr) As LongPtr
Const minDelay As Long = 1
Dim result As LongPtr
'
If lpTimerFunc = 0 Then Exit Function
If uElapse < minDelay Then uElapse = minDelay
'
If Not InitTimers(False) Then Exit Function
result = SetTimerAPI(hWnd, nIDEvent, USER_TIMER_MAXIMUM, lpTimerFunc)
If result = 0 Then Exit Function
KillTimerAPI hWnd, nIDEvent 'No longer needed
'
If hWnd = 0 Then
hWnd = Application.hWnd 'Save the implicit hWnd
nIDEvent = result
End If
'
Dim sID As String: sID = GetTimerID(hWnd, nIDEvent)
Dim remoteResult As Boolean
'
On Error Resume Next
remoteResult = m_remoteTimers.AddTimer(hWnd, nIDEvent, sID, uElapse)
On Error GoTo 0
If Not remoteResult Then Exit Function
'
On Error Resume Next
m_localTimers.Remove sID
m_localTimers.Add lpTimerFunc, sID 'Dispatch will need the TimerProc later
On Error GoTo 0
'
SetTimer = result
End Function
'*******************************************************************************
'The only TimerProc called remotely
'*******************************************************************************
Private Sub TimerProc(ByVal hWnd As LongPtr _
, ByVal wMsg As Long _
, ByVal nIDEvent As LongPtr _
, ByVal wTime As Long)
Dim oPtr As LongPtr: oPtr = ObjPtr(ThisWorkbook)
Dim rHWnd As LongPtr: rHWnd = GetReadyHWnd()
'
KillTimerAPI rHWnd, oPtr 'Kill the only TimerProc
If oPtr = nIDEvent Then Exit Sub
'
On Error Resume Next
Dim tProc As LongPtr: tProc = m_localTimers(GetTimerID(hWnd, nIDEvent))
On Error GoTo 0
If tProc = 0 Then Exit Sub 'State was lost
'
Dim sDisp As New SafeDispatch 'Will dispatch msg on termination
sDisp.Init hWnd, wMsg, nIDEvent, tProc, wTime, m_bookID
'
SetTimerAPI rHWnd, oPtr, USER_TIMER_MAXIMUM, AddressOf TimerProc
End Sub
'*******************************************************************************
'Utility for collection keys
'*******************************************************************************
Private Function GetTimerID(ByVal hWnd As LongPtr _
, ByVal nIDEvent As LongPtr) As String
GetTimerID = hWnd & "_" & nIDEvent
End Function
'*******************************************************************************
'Safe wrapper around Win API
'https://docs.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-killtimer
'Parameters:
' - hWnd: a handle to the window associated with the specified timer
' - nIDEvent: the timer to be destroyed
'*******************************************************************************
Public Function KillTimer(ByVal hWnd As LongPtr _
, ByVal nIDEvent As LongPtr) As Long
Dim sID As String: sID = GetTimerID(hWnd, nIDEvent)
Dim remoteResult As Boolean
'
On Error Resume Next
remoteResult = m_remoteTimers.DeleteTimer(sID)
m_localTimers.Remove sID
On Error GoTo 0
'
If remoteResult Then KillTimer = 1
End Function
'*******************************************************************************
'Removes all existing timers
'*******************************************************************************
Public Sub RemoveAllTimers()
On Error Resume Next
If m_remoteTimers.DeleteAllTimers() Then Set m_localTimers = New Collection
On Error GoTo 0
End Sub
'*******************************************************************************
'Returns 'True' only if the object is set and still connected to the remote app
'*******************************************************************************
Private Function IsConnected(ByVal obj As Object) As Boolean
If Not obj Is Nothing Then
IsConnected = (TypeName(obj) <> "Object")
End If
End Function
'*******************************************************************************
'Initializes the remote application instance and its resources e.g. code book
'Works regardless if VB Object Model access is on or off
'*******************************************************************************
Public Function InitTimers(Optional ByVal reCreateBook As Boolean = False) As Boolean
If IsConnected(m_remoteTimers) Then
InitTimers = True
Exit Function
End If
'
Dim app As Application
Dim bookExists As Boolean: bookExists = IsFile(GetBookPath())
'
If reCreateBook And bookExists Then
On Error Resume Next
Kill GetBookPath()
bookExists = (Err.Number <> 0)
On Error GoTo 0
If bookExists Then Exit Function
End If
If bookExists Then
Set app = GetRemoteApp()
Else
Set app = CreateBookInRemoteApp()
End If
'
Dim tProc As LongPtr: tProc = VBA.Int(AddressOf TimerProc)
Dim oPtr As LongPtr: oPtr = ObjPtr(ThisWorkbook)
Dim rHWnd As LongPtr: rHWnd = GetReadyHWnd()
m_bookID = CStr(oPtr)
'
Set m_localTimers = New Collection
Set m_remoteTimers = app.Run("GetBookTimers", rHWnd, m_bookID, tProc)
SetTimerAPI rHWnd, oPtr, USER_TIMER_MAXIMUM, tProc
'
InitTimers = True
End Function
Private Function IsFile(ByVal filePath As String) As Boolean
On Error Resume Next
IsFile = ((GetAttr(filePath) And vbDirectory) <> vbDirectory)
On Error GoTo 0
End Function
Private Function GetBookPath() As String
Dim folderPath As String: folderPath = Environ$("temp")
GetBookPath = folderPath & Application.PathSeparator & BOOK_NAME
End Function
'*******************************************************************************
'Returns the existing remote app or opens a new one if needed
'*******************************************************************************
Private Function GetRemoteApp() As Application
Dim mainHWnd As LongPtr
Dim remoteHWnd As LongPtr
Dim app As Application
Dim book As Workbook
'
Do
Set app = GetNextApplication(mainHWnd)
If Not app Is Nothing Then
Set book = Nothing
remoteHWnd = 0
'
On Error Resume Next
Set book = app.Workbooks(BOOK_NAME)
If Not book Is Nothing Then
remoteHWnd = app.Run("GetReadyHWnd")
End If
On Error GoTo 0
If remoteHWnd = GetReadyHWnd() Then Exit Do
Set app = Nothing
End If
Loop Until mainHWnd = 0
If app Is Nothing Then
Set app = NewApp()
app.Workbooks.Open GetBookPath(), False, False
End If
Set GetRemoteApp = app
End Function
Private Function GetNextApplication(ByRef mainHWnd As LongPtr) As Application
mainHWnd = FindWindowEx(0, mainHWnd, "XLMAIN", vbNullString)
If mainHWnd = 0 Then Exit Function
'
Dim w As Window
For Each w In Application.Windows
If w.hWnd = mainHWnd Then Exit Function
Next w
'
Const OBJID_NATIVEOM As Long = &HFFFFFFF0
Dim deskHWnd As LongPtr
Dim excelHWnd As LongPtr
Dim wnd As Window
'
deskHWnd = FindWindowEx(mainHWnd, 0, "XLDESK", vbNullString)
If deskHWnd = 0 Then Exit Function
excelHWnd = FindWindowEx(deskHWnd, 0, "EXCEL7", vbNullString)
If excelHWnd = 0 Then Exit Function
'
AccessibleObjectFromWindow excelHWnd, OBJID_NATIVEOM, IDispGuid(), wnd
If wnd Is Nothing Then Exit Function
Set GetNextApplication = wnd.Application
End Function
Private Function IDispGuid() As GUID
With IDispGuid 'IDispatch
.data1 = &H20400
.data4(0) = &HC0
.data4(7) = &H46
End With
End Function
'*******************************************************************************
'Creates a new app instance and sets certain properties
'*******************************************************************************
Private Function NewApp() As Application
Set NewApp = New Application
With NewApp
.Visible = False
.PrintCommunication = False
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
.Interactive = False
End With
End Function
'*******************************************************************************
'Creates a book, adds the code, saves it and returns the Application instance
'*******************************************************************************
Private Function CreateBookInRemoteApp() As Application
Const vbext_ct_StdModule As Long = 1
Const vbext_ct_ClassModule As Long = 2
Const publicNotCreatable As Long = 2
'
Dim app As Application
Dim book As Workbook
Dim isVBOMOn As Boolean: isVBOMOn = IsVBOMEnabled()
'
If Not isVBOMOn Then
If Not EnableOfficeVBOM(True) Then Exit Function
End If
'
On Error GoTo SafeExit
Set app = NewApp()
Set book = app.Workbooks.Add
'
With book.VBProject.VBComponents.Add(vbext_ct_ClassModule).CodeModule
If .CountOfLines > 0 Then .DeleteLines 1, .CountOfLines
.AddFromString TimerContainerCode()
.Parent.Name = "TimerContainer"
End With
With book.VBProject.VBComponents.Add(vbext_ct_ClassModule).CodeModule
If .CountOfLines > 0 Then .DeleteLines 1, .CountOfLines
.AddFromString BookTimersCode()
.Parent.Name = "BookTimers"
.Parent.Properties("Instancing") = publicNotCreatable
End With
With book.VBProject.VBComponents.Add(vbext_ct_ClassModule).CodeModule
If .CountOfLines > 0 Then .DeleteLines 1, .CountOfLines
.AddFromString AppTimersCode()
.Parent.Name = "AppTimers"
End With
With book.VBProject.VBComponents.Add(vbext_ct_StdModule).CodeModule
If .CountOfLines > 0 Then .DeleteLines 1, .CountOfLines
.AddFromString LibRemoteCode()
.Parent.Name = "LibRemote"
End With
book.SaveAs GetBookPath(), XlFileFormat.xlOpenXMLAddIn
'
If Not isVBOMOn Then
book.Close False
app.Quit
Set app = Nothing
EnableOfficeVBOM False
Set app = NewApp()
app.Workbooks.Open GetBookPath(), False, False
End If
Set CreateBookInRemoteApp = app
SafeExit:
End Function
'*******************************************************************************
'Checks if VBProject is accessible programmatically. Setting is app level
'*******************************************************************************
Private Function IsVBOMEnabled() As Boolean
On Error Resume Next
IsVBOMEnabled = Not Application.VBE.ActiveVBProject Is Nothing
On Error GoTo 0
End Function
'*******************************************************************************
'Apps like AutoCAD have the Object Model access on by default. This method is
' desgined for Microsoft Office VBA-capable applications
'*******************************************************************************
Private Function EnableOfficeVBOM(ByVal newValue As Boolean) As Boolean
Dim i As Long: i = IIf(newValue, 1, 0)
Dim rKey As String
rKey = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & Application.Version _
& "\" & Replace(Application.Name, "Microsoft ", vbNullString) _
& "\Security\AccessVBOM"
On Error Resume Next
CreateObject("WScript.Shell").RegWrite rKey, i, "REG_DWORD"
EnableOfficeVBOM = (Err.Number = 0)
On Error GoTo 0
End Function
'*******************************************************************************
'Returns the handle for the main VB IDE window
'*******************************************************************************
Private Function GetVBIDEHWnd() As LongPtr
If m_VBIDEHWnd = 0 Then
If IsVBOMEnabled() Then
m_VBIDEHWnd = Application.VBE.MainWindow.hWnd
Else
EnumThreadWindows GetCurrentThreadId, AddressOf EnumThreadWndProcVBIDE, 0
End If
End If
GetVBIDEHWnd = m_VBIDEHWnd
End Function
Private Function EnumThreadWndProcVBIDE(ByVal hWnd As LongPtr _
, ByVal lParam As LongPtr) As Long
Const className As String = "wndclass_desked_gsk"
Const bufferSize As Long = 260
Dim cName As String * bufferSize
'
If Left$(cName, GetClassName(hWnd, cName, bufferSize)) = className Then
m_VBIDEHWnd = hWnd
Exit Function
End If
EnumThreadWndProcVBIDE = 1
End Function
'*******************************************************************************
'Returns the handle for the '<Ready>' window under the parent 'Locals' window
'*******************************************************************************
Private Function GetReadyHWnd() As LongPtr
Static readyHWnd As LongPtr
If readyHWnd = 0 Then
Dim localsHWnd As LongPtr
localsHWnd = FindWindowEx(GetVBIDEHWnd(), 0, vbNullString, "Locals")
readyHWnd = FindWindowEx(localsHWnd, 0, "Edit", vbNullString)
End If
GetReadyHWnd = readyHWnd
End Function
'*******************************************************************************
'Code running 'on the other side'
'*******************************************************************************
Private Function LibRemoteCode() As String
Dim s As String
Const n As String = vbNewLine
s = s & "Option Explicit" & n
s = s & "" & n
s = s & "#If VBA7 = 0 Then" & n
s = s & " Public Enum LongPtr" & n
s = s & " [_]" & n
s = s & " End Enum" & n
s = s & "#End If" & n
s = s & "" & n
s = s & "#If VBA7 Then" & n
s = s & " Private Declare PtrSafe Function IsWindow Lib ""user32"" (ByVal hWnd As LongPtr) As Long" & n
s = s & " Private Declare PtrSafe Function SendMessage Lib ""user32"" Alias ""SendMessageA"" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr" & n
s = s & " Public Declare PtrSafe Sub Sleep Lib ""kernel32"" (ByVal dwMilliseconds As Long)" & n
s = s & "#Else" & n
s = s & " Private Declare Function IsWindow Lib ""user32"" (ByVal hWnd As Long) As Long" & n
s = s & " Private Declare Function SendMessage Lib ""user32"" Alias ""SendMessageA"" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long" & n
s = s & " Public Declare Sub Sleep Lib ""kernel32"" (ByVal dwMilliseconds As Long)" & n
s = s & "#End If" & n
s = s & "" & n
s = s & "Private m_appTimers As AppTimers" & n
s = s & "Private m_readyHWnd As LongPtr" & n
s = s & "" & n
s = s & "Public Function GetReadyHWnd() As LongPtr" & n
s = s & " GetReadyHWnd = m_readyHWnd" & n
s = s & "End Function" & n
s = s & "" & n
s = s & "Public Function GetBookTimers(ByVal readyHWnd As LongPtr _" & n
s = s & " , ByVal bookID As String _" & n
s = s & " , ByVal tProc As LongPtr) As BookTimers" & n
s = s & " If m_readyHWnd = 0 Then" & n
s = s & " m_readyHWnd = readyHWnd" & n
s = s & " Set m_appTimers = New AppTimers" & n
s = s & " Application.OnTime Now(), ""MainLoop""" & n
s = s & " End If" & n
s = s & " With New BookTimers" & n
s = s & " .Init bookID, tProc" & n
s = s & " m_appTimers.Add .Self" & n
s = s & " Set GetBookTimers = .Self" & n
s = s & " End With" & n
s = s & "End Function" & n
s = s & "" & n
s = s & "Public Sub MainLoop()" & n
s = s & " Do While IsWindow(m_readyHWnd)" & n
s = s & " m_appTimers.CheckRefs" & n
s = s & " If m_appTimers.Count > 0 And m_appTimers.CanPost Then" & n
s = s & " If Not m_appTimers.PopIfNeeded Then Sleep 1" & n
s = s & " Else" & n
s = s & " Sleep 1" & n
s = s & " End If" & n
s = s & " DoEvents" & n
s = s & " Loop" & n
s = s & " Set m_appTimers = Nothing" & n
s = s & " Application.Quit" & n
s = s & "End Sub" & n
s = s & "" & n
s = s & "Public Function IsIDEReady() As Boolean" & n
s = s & " Const readyLabelCurANSI As String = ""1758492059378.1308"" '<Ready>" & n
s = s & " Static readyLabel As Currency" & n
s = s & " Const WM_GETTEXT As Long = &HD" & n
s = s & " Dim buff As Currency" & n
s = s & " '" & n
s = s & " If readyLabel = 0 Then readyLabel = CCur(readyLabelCurANSI)" & n
s = s & " If SendMessage(m_readyHWnd, WM_GETTEXT, 8, VarPtr(buff)) = 0 Then Exit Function" & n
s = s & " IsIDEReady = (buff = readyLabel)" & n
s = s & "End Function" & n
s = s & "" & n
s = s & "Public Function NowMSec() As Date" & n
s = s & " Const secondsPerDay As Long = 24& * 60& * 60&" & n
s = s & " NowMSec = Date + Round(Timer, 3) / secondsPerDay" & n
s = s & "End Function"
LibRemoteCode = s
End Function
Private Function TimerContainerCode() As String
Dim s As String
Const n As String = vbNewLine
s = s & "Option Explicit" & n
s = s & "" & n
s = s & "Private m_hWnd As LongPtr" & n
s = s & "Private m_nIDEvent As LongPtr" & n
s = s & "Private m_id As String" & n
s = s & "Private m_delayMs As Long" & n
s = s & "Private m_earliestTime As Date" & n
s = s & "Private m_originalTime As Date" & n
s = s & "" & n
s = s & "Public Sub Init(ByRef hWnd As LongPtr _" & n
s = s & " , ByRef nIDEvent As LongPtr _" & n
s = s & " , ByRef sID As String _" & n
s = s & " , ByRef delayMs As Long _" & n
s = s & " , ByRef callTime As Date)" & n
s = s & " m_hWnd = hWnd" & n
s = s & " m_nIDEvent = nIDEvent" & n
s = s & " m_id = sID" & n
s = s & " m_delayMs = delayMs" & n
s = s & " m_earliestTime = callTime" & n
s = s & " m_originalTime = m_earliestTime" & n
s = s & "End Sub" & n
s = s & "Public Function Self() As TimerContainer" & n
s = s & " Set Self = Me" & n
s = s & "End Function" & n
s = s & "Public Property Get hWnd() As LongPtr" & n
s = s & " hWnd = m_hWnd" & n
s = s & "End Property" & n
s = s & "Public Property Get EventID() As LongPtr" & n
s = s & " EventID = m_nIDEvent" & n
s = s & "End Property" & n
s = s & "Public Property Get ID() As String" & n
s = s & " ID = m_id" & n
s = s & "End Property" & n
s = s & "Public Property Get Delay() As Long" & n
s = s & " Delay = m_delayMs" & n
s = s & "End Property" & n
s = s & "Public Property Get EarliestTime() As Date" & n
s = s & " EarliestTime = m_earliestTime" & n
s = s & "End Property" & n
s = s & "" & n
s = s & "Public Sub UpdateTime()" & n
s = s & " Const msPerDay As Long = 24& * 60& * 60& * 1000&" & n
s = s & " Dim daysDelay As Double" & n
s = s & " Dim skipCount As Long" & n
s = s & " '" & n
s = s & " daysDelay = m_delayMs / msPerDay" & n
s = s & " skipCount = Int((NowMSec - m_originalTime) / daysDelay)" & n
s = s & " m_earliestTime = m_originalTime + (skipCount + 1) * daysDelay" & n
s = s & "End Sub"
TimerContainerCode = s
End Function
Private Function AppTimersCode() As String
Dim s As String
Const n As String = vbNewLine
s = s & "Option Explicit" & n
s = s & "" & n
s = s & "Private m_bookTimers As Collection" & n
s = s & "" & n
s = s & "Private Sub Class_Initialize()" & n
s = s & " Set m_bookTimers = New Collection" & n
s = s & "End Sub" & n
s = s & "" & n
s = s & "Private Sub Class_Terminate()" & n
s = s & " Set m_bookTimers = Nothing" & n
s = s & "End Sub" & n
s = s & "" & n
s = s & "Public Sub Add(ByVal bTimers As BookTimers)" & n
s = s & " On Error Resume Next" & n
s = s & " m_bookTimers.Remove bTimers.ID" & n
s = s & " On Error GoTo 0" & n
s = s & " m_bookTimers.Add bTimers, bTimers.ID" & n
s = s & "End Sub" & n
s = s & "" & n
s = s & "Public Function CanPost() As Boolean" & n
s = s & " Dim bt As BookTimers" & n
s = s & " For Each bt In m_bookTimers" & n
s = s & " If Not bt.CanPost Then Exit Function" & n
s = s & " Next bt" & n
s = s & " CanPost = True" & n
s = s & "End Function" & n
s = s & "" & n
s = s & "Public Sub CheckRefs()" & n
s = s & " Dim bt As BookTimers" & n
s = s & " For Each bt In m_bookTimers" & n
s = s & " If bt.RefsCount = 3 Then" & n
s = s & " m_bookTimers.Remove bt.ID" & n
s = s & " bt.KillBookTimer" & n
s = s & " End If" & n
s = s & " Next bt" & n
s = s & "End Sub" & n
s = s & "" & n
s = s & "Public Function Count() As Long" & n
s = s & " Count = m_bookTimers.Count" & n
s = s & "End Function" & n
s = s & "" & n
s = s & "Public Function PopIfNeeded() As Boolean" & n
s = s & " Dim bt As BookTimers" & n
s = s & " Dim minBT As BookTimers" & n
s = s & " '" & n
s = s & " For Each bt In m_bookTimers" & n
s = s & " If minBT Is Nothing Then" & n
s = s & " If bt.Count > 0 Then Set minBT = bt" & n
s = s & " Else" & n
s = s & " If bt.Count > 0 Then" & n
s = s & " If bt.EarliestTime < minBT.EarliestTime Then" & n
s = s & " Set minBT = bt" & n
s = s & " End If" & n
s = s & " End If" & n
s = s & " End If" & n
s = s & " Next bt" & n
s = s & " If minBT Is Nothing Then" & n
s = s & " PopIfNeeded = False" & n
s = s & " Else" & n
s = s & " PopIfNeeded = minBT.PopIfNeeded()" & n
s = s & " End If" & n
s = s & "End Function"
AppTimersCode = s
End Function
Private Function BookTimersCode() As String
Dim s As String
Const n As String = vbNewLine
s = s & "Option Explicit" & n
s = s & "" & n
s = s & "#If VBA7 Then" & n
s = s & " Private Declare PtrSafe Sub CopyMemory Lib ""kernel32"" Alias ""RtlMoveMemory"" (Destination As Any, Source As Any, ByVal Length As LongPtr)" & n
s = s & " Private Declare PtrSafe Function IsWindow Lib ""user32"" (ByVal hWnd As LongPtr) As Long" & n
s = s & " Private Declare PtrSafe Function PostMessage Lib ""user32"" Alias ""PostMessageA"" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long" & n
s = s & "#Else" & n
s = s & " Private Declare Sub CopyMemory Lib ""kernel32"" Alias ""RtlMoveMemory"" (Destination As Any, Source As Any, ByVal Length As Long)" & n
s = s & " Private Declare Function IsWindow Lib ""user32"" (ByVal hWnd As Long) As Long" & n
s = s & " Private Declare Function PostMessage Lib ""user32"" Alias ""PostMessageA"" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long" & n
s = s & "#End If" & n
s = s & "" & n
s = s & "#If Win64 Then" & n
s = s & " Private Const PTR_SIZE As Long = 8" & n
s = s & "#Else" & n
s = s & " Private Const PTR_SIZE As Long = 4" & n
s = s & "#End If" & n
s = s & "" & n
s = s & "Private m_canPost As Boolean" & n
s = s & "Private m_id As String" & n
s = s & "Private m_refCount As Variant" & n
s = s & "Private m_timers As Collection" & n
s = s & "Private m_tProc As LongPtr" & n
s = s & "" & n
s = s & "Public Sub Init(ByVal bookID As String, ByVal tProc As LongPtr)" & n
s = s & " m_id = bookID" & n
s = s & " m_tProc = tProc" & n
s = s & "End Sub" & n
s = s & "" & n
s = s & "Private Sub Class_Initialize()" & n
s = s & " Set m_timers = New Collection" & n
s = s & " SetRefCount" & n
s = s & " m_canPost = True" & n
s = s & "End Sub" & n
s = s & "" & n
s = s & "Private Sub Class_Terminate()" & n
s = s & " Set m_timers = Nothing" & n
s = s & " On Error Resume Next" & n
s = s & " DeleteSetting ""SafeTimers"", m_id" & n
s = s & " On Error GoTo 0" & n
s = s & "End Sub" & n
s = s & "" & n
s = s & "Private Sub SetRefCount()" & n
s = s & " Const VT_BYREF As Long = &H4000" & n
s = s & " Dim iUnk As IUnknown: Set iUnk = Me" & n
s = s & " m_refCount = ObjPtr(iUnk) + PTR_SIZE" & n
s = s & " CopyMemory m_refCount, vbLong + VT_BYREF, 2" & n
s = s & "End Sub" & n
s = s & "" & n
s = s & "Public Property Get RefsCount() As Long" & n
s = s & " RefsCount = GetLongByRef(m_refCount)" & n
s = s & "End Property" & n
s = s & "Private Function GetLongByRef(ByRef v As Variant) As Long" & n
s = s & " GetLongByRef = v" & n
s = s & "End Function" & n
s = s & "" & n
s = s & "Public Function Count() As Long" & n
s = s & " Count = m_timers.Count" & n
s = s & "End Function" & n
s = s & "" & n
s = s & "Public Property Get ID() As String" & n
s = s & " ID = m_id" & n
s = s & "End Property" & n
s = s & "" & n
s = s & "Public Function Self() As BookTimers" & n
s = s & " Set Self = Me" & n
s = s & "End Function" & n
s = s & "" & n
s = s & "Public Property Get CanPost() As Boolean" & n
s = s & " If Not m_canPost Then" & n
s = s & " m_canPost = (GetSetting(""SafeTimers"", m_id, ""CanPost"") = ""True"")" & n
s = s & " If m_canPost Then" & n
s = s & " Dim lostID As String" & n
s = s & " lostID = GetSetting(""SafeTimers"", m_id, ""LostID"")" & n
s = s & " If LenB(lostID) > 0 Then" & n
s = s & " DeleteTimer lostID" & n
s = s & " DeleteSetting ""SafeTimers"", m_id, ""LostID""" & n
s = s & " End If" & n
s = s & " End If" & n
s = s & " End If" & n
s = s & " CanPost = m_canPost" & n
s = s & "End Property" & n
s = s & "" & n
s = s & "Public Property Get EarliestTime() As Date" & n
s = s & " EarliestTime = m_timers(1).EarliestTime" & n
s = s & "End Property" & n
s = s & "" & n
s = s & "Public Function AddTimer(ByVal hWnd As LongPtr _" & n
s = s & " , ByVal nIDEvent As LongPtr _" & n
s = s & " , ByVal sID As String _" & n
s = s & " , ByVal delayMs As Long) As Boolean" & n
s = s & " DeleteTimer sID" & n
s = s & " With New TimerContainer" & n
s = s & " Const msPerDay As Long = 24& * 60& * 60& * 1000&" & n
s = s & " Dim nextRun As Date: nextRun = NowMSec() + delayMs / msPerDay" & n
s = s & " '" & n
s = s & " .Init hWnd, nIDEvent, sID, delayMs, nextRun" & n
s = s & " InsertTimer .Self" & n
s = s & " End With" & n
s = s & " AddTimer = True" & n
s = s & "End Function" & n
s = s & "" & n
s = s & "Public Function DeleteTimer(ByVal sID As String) As Boolean" & n
s = s & " On Error Resume Next" & n
s = s & " m_timers.Remove sID" & n
s = s & " DeleteTimer = (Err.Number = 0)" & n
s = s & " On Error GoTo 0" & n
s = s & "End Function" & n
s = s & "" & n
s = s & "Public Function DeleteAllTimers() As Boolean" & n
s = s & " Set m_timers = New Collection" & n
s = s & " DeleteAllTimers = True" & n
s = s & "End Function" & n
s = s & "" & n
s = s & "Private Sub InsertTimer(ByRef container As TimerContainer)" & n
s = s & " Dim tc As TimerContainer" & n
s = s & " Dim i As Long: i = 1" & n
s = s & " '" & n
s = s & " For Each tc In m_timers" & n
s = s & " If tc.EarliestTime > container.EarliestTime Then Exit For" & n
s = s & " i = i + 1" & n
s = s & " Next tc" & n
s = s & " If m_timers.Count = 0 Or i > m_timers.Count Then" & n
s = s & " m_timers.Add Item:=container, Key:=container.ID" & n
s = s & " Else" & n
s = s & " m_timers.Add Item:=container, Key:=container.ID, Before:=i" & n
s = s & " End If" & n
s = s & "End Sub" & n
s = s & "" & n
s = s & "Public Function PopIfNeeded() As Boolean" & n
s = s & " Const WM_TIMER As Long = &H113" & n
s = s & " Dim tc As TimerContainer: Set tc = m_timers(1)" & n
s = s & " '" & n
s = s & " If tc.EarliestTime > NowMSec() Then Exit Function" & n
s = s & " If Not IsIDEReady() Then Exit Function" & n
s = s & " '" & n
s = s & " m_timers.Remove 1" & n
s = s & " If PostMessage(tc.hWnd, WM_TIMER, tc.EventID, m_tProc) = 0& Then" & n
s = s & " If IsWindow(tc.hWnd) = 0& Then Exit Function" & n
s = s & " End If" & n
s = s & " m_canPost = False" & n
s = s & " PopIfNeeded = True" & n
s = s & " '" & n
s = s & " tc.UpdateTime" & n
s = s & " InsertTimer tc" & n
s = s & "End Function" & n
s = s & "" & n
s = s & "Public Sub KillBookTimer()" & n
s = s & " Const WM_TIMER As Long = &H113" & n
s = s & " Dim rHWnd As LongPtr: rHWnd = GetReadyHWnd()" & n
s = s & " Dim tID As LongPtr: tID = VBA.Int(m_id)" & n
s = s & " '" & n
s = s & " Do While IsWindow(rHWnd)" & n
s = s & " If IsIDEReady() Then" & n
s = s & " If PostMessage(rHWnd, WM_TIMER, tID, m_tProc) <> 0& Then Exit Do" & n
s = s & " End If" & n
s = s & " Sleep 1" & n
s = s & " Loop" & n
s = s & "End Sub"
BookTimersCode = s
End Function
```
```SafeDispatch``` class module:
```VBA
'''=============================================================================
''' Excel-VBA-SafeTimers
''' ----------------------------------------------------
''' https://github.com/cristianbuse/Excel-VBA-SafeTimers
''' ----------------------------------------------------
''' MIT License
'''
''' Copyright (c) 2022 Ion Cristian Buse
'''
''' Permission is hereby granted, free of charge, to any person obtaining a copy
''' of this software and associated documentation files (the "Software"), to
''' deal in the Software without restriction, including without limitation the
''' rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
''' sell copies of the Software, and to permit persons to whom the Software is
''' furnished to do so, subject to the following conditions:
'''
''' The above copyright notice and this permission notice shall be included in
''' all copies or substantial portions of the Software.
'''
''' THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
''' IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
''' FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
''' AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
''' LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
''' FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
''' IN THE SOFTWARE.
'''=============================================================================
Option Explicit
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type MSG
hWnd As LongPtr
wMsg As Long
wParam As LongPtr
lParam As LongPtr
wTime As Long
pt As POINTAPI
End Type
#If VBA7 Then
Private Declare PtrSafe Function DispatchMessage Lib "user32" Alias "DispatchMessageA" (lpMsg As MSG) As LongPtr
Private Declare PtrSafe Function KillTimerAPI Lib "user32" Alias "KillTimer" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
Private Declare PtrSafe Function SetTimerAPI Lib "user32" Alias "SetTimer" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
#Else
Private Declare Function DispatchMessage Lib "user32" Alias "DispatchMessageA" (lpMsg As MSG) As Long
Private Declare Function KillTimerAPI Lib "user32" Alias "KillTimer" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Function SetTimerAPI Lib "user32" Alias "SetTimer" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
#End If
Private m_msg As MSG
Private m_bookID As String
Public Sub Init(ByVal hWnd As LongPtr _
, ByVal wMsg As Long _
, ByVal wParam As LongPtr _
, ByVal lParam As LongPtr _
, ByVal wTime As Long _
, ByVal bookID As String)
With m_msg
.hWnd = hWnd
.wMsg = wMsg
.wParam = wParam
.lParam = lParam
.wTime = wTime
End With
m_bookID = bookID
End Sub
Private Sub Class_Terminate()
If LenB(m_bookID) = 0 Then Exit Sub 'In case state was lost
'
Const USER_TIMER_MAXIMUM As Long = &H7FFFFFFF 'Around 25 days
With m_msg
If SetTimerAPI(.hWnd, .wParam, USER_TIMER_MAXIMUM, .lParam) <> 0 Then
DispatchMessage m_msg
KillTimerAPI .hWnd, .wParam
Else
SaveSetting "SafeTimers", m_bookID, "LostID", .hWnd & "_" & .wParam
End If
End With
SaveSetting "SafeTimers", m_bookID, "CanPost", "True"
End Sub
```
## Demo
Here is a quick demo running 2 timers that stop after running 20 times each:
```VBA
Option Explicit
Private Const FIXED_ID As LongPtr = 5
Private m_dynamicID As LongPtr
Public Sub DemoMain()
SetTimer ThisWorkbook.Windows(1).hWnd, FIXED_ID, 20, AddressOf TimerProc
m_dynamicID = SetTimer(0, 0, 50, AddressOf TimerProc)
End Sub
Private Sub TimerProc(ByVal hWnd As LongPtr _
, ByVal wMsg As Long _
, ByVal nIDEvent As LongPtr _
, ByVal wTime As Long)
Select Case nIDEvent
Case FIXED_ID
FixedIDTimer hWnd, nIDEvent
Case m_dynamicID
DynamicIDTimer hWnd, nIDEvent
Case Else
RemoveAllTimers
End Select
End Sub
Private Sub FixedIDTimer(ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr)
Static c As Long
c = c + 1
If c = 20 Then KillTimer hWnd, nIDEvent
Debug.Print Round(CDbl(Timer), 3), hWnd, nIDEvent, "Fixed"
End Sub
Private Sub DynamicIDTimer(ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr)
Static c As Long
c = c + 1
If c = 20 Then KillTimer hWnd, nIDEvent
Debug.Print Round(CDbl(Timer), 3), hWnd, nIDEvent, "Dynamic"
End Sub
```
And of course, the 'gif' - @Greedo™ - bit small to fit the 2MB limit but hopefully not too small:
***
Any feedback or comments are welcome!
There are a lot of decisions I took as I improved on my own solution and some might not be obvious. If you have any questions then please use the comments section.
Thank you!