Safe Windows API Timers for Excel

Question

Update Feb 2023

This solution is no longer maintained here or on GitHub, mainly because I do not need a timer solution anymore. As seen below, the only purpose of this approach was to get a reliable, crash-free call that can get Excel out of UDF mode - which I've eventually achieved by posting a WM_DESTROY message to a userform. See here. The below is now purely an exercise in how to work from a remote application instance and get somewhat reliable timer functionality without crashes.

---

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.

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 has done an excellent job in documenting WIN API timers here and even posted this framework which provides nice wrappers. Unfortunately, this is still crashing.

Then there is stuff like this. 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 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 and 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 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 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 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:

'''=============================================================================
''' 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:

'''=============================================================================
''' 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:

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' - @GreedoTM - bit small to fit the 2MB limit but hopefully not too small:

gif

---

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!

---

Update Feb 2023

This solution is no longer maintained here or on GitHub, mainly because I do not need a timer solution anymore. As seen above, the only purpose of this approach was to get a reliable, crash-free call that can get Excel out of UDF mode - which I've eventually achieved by posting a WM_DESTROY message to a userform. See here. The above is now purely an exercise in how to work from a remote application instance and get somewhat reliable timer functionality without crashes.

• Sancarn: "... assembly but it does not work at all" - It only works in Userforms. I too had the same issue as yourself initially 😅. Something to bear in mind is for EnableOfficeVBOM - I believe in some version including mine, you have to open the macro security in order for Excel to open/register that VBOM is now enabled. Alternatively, would it be better to use SaveCopyAs()?
• Cristian Buse: Thanks @Sancarn - Maybe I will try the 'trick' timer with a userform at some point. Anyways, I kind of gave up on timers entirely because all I wanted to do was to get an async call to get out of UDF mode (as explained) in the 'Motivation' section. I now solve this elegantly with a WM_DESTROY posted to a form. See here. So, I gave up on trying to improve on this remote app approach entirely (I should probably remove the GitHub repo as well). and update this answer with a note.
• Cristian Buse: @Sancarn Thanks for the EnableOfficeVBOM note - I will keep that in mind if I ever need it. Using SaveCopyAs was actually the first thing I tried but I quickly dismissed it for 2 reasons: 1) The current book using the solution would have needed the remote modules as well and depending on the size of the book, it might take too long to save a copy and to open on subsequent use - I basically went for the lightweight approach; 2) The saved book would sometimes not open, although I never got to find out why. Anyway, thank you for the feedback - much appreciated sir!
• Greedo: @CristianBuse I would be surprised if it doesn't work the way you describe in all Excel versions, but you could imagine Excel caching some state internally to %AppData%, and it only reads the Registry Key, not at startup, but at the point of viewing the relevant menu. But maybe Sancarn is talking about a single App Instance being unlocked in-place which isn't the use-case in your remote workbook (or what I have in mind) but useful info nevertheless
• Sancarn: @CristianBuse " I never needed to open the macro security. Once the registry is changed, any new instance..." - Of course! I totally forgot you were creating a new instance of the application. Anyhow, getting some sort of stable timer with as few dependencies as possible is still useful, even if you did give up, so I wouldn't delete the thread/github, perhaps public archive though :)

Answer 1

This is a pet peeve of mine:

s = s & "Public Sub Init(ByRef hWnd As LongPtr _" & n

I hate large blocks of code with this type of concatenation. I prefer to add each line to a Dictionary and join its keys. But since the text being concatenated is quite large and prewritten, I will spend 5 minutes figuring out how to generate the code.

For this example I dumped some sample code into a module and wrote this function to parse the modules code and copy the result to the clipboard.

Sub PrepareCode()
 Dim Lines() As String
 With ThisWorkbook.VBProject.VBComponents("APICode").CodeModule
 Lines = Split(.Lines(1, .CountOfLines), vbNewLine)
 End With
 
 Dim n As Long
 For n = 0 To UBound(Lines)
 Lines(n) = "Lines(" & n & ") = " & Chr(34) & Replace(Lines(n), Chr(34), String(2, 34)) & Chr(34)
 Next
 
 With New DataObject
 .SetText Join(Lines, vbNewLine)
 .PutInClipboard
 End With
End Sub

APICode: Module

#If VBA7 Then
 Private Declare PtrSafe Function IsWindow Lib "user32" (ByVal hWnd As LongPtr) As Long
 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
 Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
 Private Declare Function IsWindow Lib "user32" (ByVal hWnd As Long) As Long
 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
 Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

Output

Lines(0) = "Option Explicit"
Lines(1) = ""
Lines(2) = ""
Lines(3) = "#If VBA7 Then"
Lines(4) = " Private Declare PtrSafe Function IsWindow Lib ""user32"" (ByVal hWnd As LongPtr) As Long"
Lines(5) = " 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"
Lines(6) = " Public Declare PtrSafe Sub Sleep Lib ""kernel32"" (ByVal dwMilliseconds As Long)"
Lines(7) = "#Else"
Lines(8) = " Private Declare Function IsWindow Lib ""user32"" (ByVal hWnd As Long) As Long"
Lines(9) = " 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"
Lines(10) = " Public Declare Sub Sleep Lib ""kernel32"" (ByVal dwMilliseconds As Long)"
Lines(11) = "#End If"
Lines(12) = ""

I'm looking forward to testing this code out with a snake game I made a while back!

• Cristian Buse: I also don't like the & operator :). However, I've considered a few options before deciding on it. First, line breaks are limited (in number) and so not an option. I actually used my StringBuffer class initially but removed it because I did not want the extra reference. I considered a Dictionary but that would be another reference too, so no. I also considered an array but did not like that the code is not aligned when switching from 9 to 10 and 99 to 100 index. So, I ended up with the simplest solution, ugly but easy to implement.
• Cristian Buse: Worth mentioning that efficiency is not an issue as the code is only used once to generate the remote workbook/add-in. Added the Remote Code folder to the repository.
• TinMan: @CristianBuse I would love to use this code but I think that I would be thrown out of the forums!!
• Cristian Buse: Haha! You made me laugh. Nice syntax :D
• TinMan: @CristianBuse it has a valid name but I think that Ad or Plus would be more acceptable.

Answer 2

Too long for a comment on @TinMan's answer

---

s = s & "Public Sub Init(ByRef hWnd As LongPtr _" & n

You should just have standard modules containing your "Remote Code"

Then in your main workbook do something like:

Dim sourceModule As CodeModule
Set sourceModule = ThisWorkbook.VBProject.VBComponents.Item("RemoteCode").CodeModule
With RemoteWorkbook.VBProject.VBComponents.Add(sourceModule.Parent.Type)
 .Name = sourceModule.Parent.Name
 With .CodeModule
 .DeleteLines 1, .CountOfLines
 .AddFromString sourceModule.Lines(1, sourceModule.CountOfLines)
 End With
End With

To copy code from your template workbook to the remote one.

This has a few advantages

• It's much easier to read, modify and test the remote code template since it is standard VBA.
• You can re-use the function that copies the module over since it just needs the VBComponent name
• (Maybe faster than concatenating a string - although this happens once only so performance shouldn't matter)

Only catch I can think of is you might need to consider duplicate definitions since your template remote code won't be stringified anymore, however that should be easy to work around. You could even comment out the whole module after editing and strip the leading apostrophe, should still be easier to work with than those strings.

• Cristian Buse: Thanks @Greedo! I already have that in the repo for both the native and the API solutions. I used them to generate the 'compacted/distributable' version. However, I finally gave up on Timers.
• Cristian Buse: I only ever needed the async calls to run calculations outside of the UDF context. Now I use a form's terminate event and it works great. See here. Literally done this in the last week or so.

Answer 3

Thanks so much for posting this, lots of inspiration in this post for a real safe timer solution, especially with the remote Application instance!

The way in which events were called seemed a little convoluted to me, so I re-wrote it to use COM Events instead.

Benefits:

• stdTimer will raise events while Edit mode is "Edit" or "Point"

Cons:

• stdTimer will not raise the Tick event while displaying Msgbox or InputBox (but will work in UserForms).
• Currently it's pretty slow to create multiple timers (1 remote instance per timer) but I do have an issue with a possible workaround.

Current usage is as follows:

Private WithEvents timer As stdTimer
Sub test()
 Set timer = stdTimer.Create(1000)
End Sub
Private Sub timer_Tick()
 Static i As Long: i = i + 1
 Debug.Print "Tick " & i
End Sub

• Cristian Buse: Very interesting approach with raising events - haven't thought of that. It does indeed feel cleaner. A few things to keep in mind: 1) You only want to use a single workbook (app instance 2) for all the timers in app instance 1 including from multiple books (all in instance 1); 2) user should still be able to edit Excel formulae while timers are firing - this was a real issue in my solutions; 3) make sure the remote app is reused if state is lost so not to end up with too many unused instances (my native version uses a nice trick to fix this with an extra book name - maybe you can use that).
• Cristian Buse: Unfortunately, I was never able to create a new app instance on Mac so that's another issue. Anyways, if you ever make any more progress on this, I would be curious to know. Thanks!