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 aWM_DESTROY message to a userform. Seehere. 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 GitHubcommit.

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 timershere and even postedthis framework which provides nice wrappers. Unfortunately, this is still crashing.

Then there is stuff likethis. 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 orApplication.OnTime but none solve my issue.

Solution

In truth, I did not even need timers. I only needed something likeApplication.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

TheLibTimers module exposes wrappers forSetTimer andKillTimer 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 theSetTimer wrapper initializes the second application instance. Alternatively, there is anInitTimers method that can be called at any time e.g. atWorkbook_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 theLibTimers module as string so that users have full visibility of the entire code. This workseven if there is no trusted access to the VB Object Model - see the privateCreateBookInRemoteApp 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 whichposts 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 safelydispatches 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 theLocals window is regularly queried remotely
• SafeDispatch.cls was added to avoid crashes when the 'Stop' button is pressed (orEnd 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 privateTimerProc inside theLibTimers 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 toSetTimer as thelpTimerFunc 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 theSleep 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 ExplicitOption 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/3Private Type GUID    data1 As Long    data2 As Integer    data3 As Integer    data4(0 To 7) As ByteEnd 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 IfConst USER_TIMER_MAXIMUM As Long = &H7FFFFFFF 'Around 25 daysPrivate Const BOOK_NAME As String = "RemoteTimersAPI_V1.xlam"Private m_localTimers As CollectionPrivate m_remoteTimers As ObjectPrivate m_VBIDEHWnd As LongPtrPrivate 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) / secondsPerDayEnd 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 = resultEnd 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 TimerProcEnd Sub'*******************************************************************************'Utility for collection keys'*******************************************************************************Private Function GetTimerID(ByVal hWnd As LongPtr _                          , ByVal nIDEvent As LongPtr) As String    GetTimerID = hWnd & "_" & nIDEventEnd 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 = 1End 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 0End 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 IfEnd 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 = TrueEnd FunctionPrivate Function IsFile(ByVal filePath As String) As Boolean    On Error Resume Next    IsFile = ((GetAttr(filePath) And vbDirectory) <> vbDirectory)    On Error GoTo 0End FunctionPrivate Function GetBookPath() As String    Dim folderPath As String: folderPath = Environ$("temp")    GetBookPath = folderPath & Application.PathSeparator & BOOK_NAMEEnd 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 = appEnd FunctionPrivate 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.ApplicationEnd FunctionPrivate Function IDispGuid() As GUID    With IDispGuid 'IDispatch        .data1 = &H20400        .data4(0) = &HC0        .data4(7) = &H46    End WithEnd 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 WithEnd 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 = appSafeExit: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 0End 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 0End 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_VBIDEHWndEnd FunctionPrivate 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 = 1End 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 = readyHWndEnd Function'*******************************************************************************'Code running 'on the other side''*******************************************************************************Private Function LibRemoteCode() As StringDim s As StringConst n As String = vbNewLines = s & "Option Explicit" & ns = s & "" & ns = s & "#If VBA7 = 0 Then" & ns = s & "    Public Enum LongPtr" & ns = s & "        [_]" & ns = s & "    End Enum" & ns = s & "#End If" & ns = s & "" & ns = s & "#If VBA7 Then" & ns = s & "    Private Declare PtrSafe Function IsWindow Lib ""user32"" (ByVal hWnd As LongPtr) As Long" & ns = 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" & ns = s & "    Public Declare PtrSafe Sub Sleep Lib ""kernel32"" (ByVal dwMilliseconds As Long)" & ns = s & "#Else" & ns = s & "    Private Declare Function IsWindow Lib ""user32"" (ByVal hWnd As Long) As Long" & ns = 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" & ns = s & "    Public Declare Sub Sleep Lib ""kernel32"" (ByVal dwMilliseconds As Long)" & ns = s & "#End If" & ns = s & "" & ns = s & "Private m_appTimers As AppTimers" & ns = s & "Private m_readyHWnd As LongPtr" & ns = s & "" & ns = s & "Public Function GetReadyHWnd() As LongPtr" & ns = s & "    GetReadyHWnd = m_readyHWnd" & ns = s & "End Function" & ns = s & "" & ns = s & "Public Function GetBookTimers(ByVal readyHWnd As LongPtr _" & ns = s & "                            , ByVal bookID As String _" & ns = s & "                            , ByVal tProc As LongPtr) As BookTimers" & ns = s & "    If m_readyHWnd = 0 Then" & ns = s & "        m_readyHWnd = readyHWnd" & ns = s & "        Set m_appTimers = New AppTimers" & ns = s & "        Application.OnTime Now(), ""MainLoop""" & ns = s & "    End If" & ns = s & "    With New BookTimers" & ns = s & "        .Init bookID, tProc" & ns = s & "        m_appTimers.Add .Self" & ns = s & "        Set GetBookTimers = .Self" & ns = s & "    End With" & ns = s & "End Function" & ns = s & "" & ns = s & "Public Sub MainLoop()" & ns = s & "    Do While IsWindow(m_readyHWnd)" & ns = s & "        m_appTimers.CheckRefs" & ns = s & "        If m_appTimers.Count > 0 And m_appTimers.CanPost Then" & ns = s & "            If Not m_appTimers.PopIfNeeded Then Sleep 1" & ns = s & "        Else" & ns = s & "            Sleep 1" & ns = s & "        End If" & ns = s & "        DoEvents" & ns = s & "    Loop" & ns = s & "    Set m_appTimers = Nothing" & ns = s & "    Application.Quit" & ns = s & "End Sub" & ns = s & "" & ns = s & "Public Function IsIDEReady() As Boolean" & ns = s & "    Const readyLabelCurANSI As String = ""1758492059378.1308"" '<Ready>" & ns = s & "    Static readyLabel As Currency" & ns = s & "    Const WM_GETTEXT As Long = &HD" & ns = s & "    Dim buff As Currency" & ns = s & "    '" & ns = s & "    If readyLabel = 0 Then readyLabel = CCur(readyLabelCurANSI)" & ns = s & "    If SendMessage(m_readyHWnd, WM_GETTEXT, 8, VarPtr(buff)) = 0 Then Exit Function" & ns = s & "    IsIDEReady = (buff = readyLabel)" & ns = s & "End Function" & ns = s & "" & ns = s & "Public Function NowMSec() As Date" & ns = s & "    Const secondsPerDay As Long = 24& * 60& * 60&" & ns = s & "    NowMSec = Date + Round(Timer, 3) / secondsPerDay" & ns = s & "End Function"LibRemoteCode = sEnd FunctionPrivate Function TimerContainerCode() As StringDim s As StringConst n As String = vbNewLines = s & "Option Explicit" & ns = s & "" & ns = s & "Private m_hWnd As LongPtr" & ns = s & "Private m_nIDEvent As LongPtr" & ns = s & "Private m_id As String" & ns = s & "Private m_delayMs As Long" & ns = s & "Private m_earliestTime As Date" & ns = s & "Private m_originalTime As Date" & ns = s & "" & ns = s & "Public Sub Init(ByRef hWnd As LongPtr _" & ns = s & "              , ByRef nIDEvent As LongPtr _" & ns = s & "              , ByRef sID As String _" & ns = s & "              , ByRef delayMs As Long _" & ns = s & "              , ByRef callTime As Date)" & ns = s & "    m_hWnd = hWnd" & ns = s & "    m_nIDEvent = nIDEvent" & ns = s & "    m_id = sID" & ns = s & "    m_delayMs = delayMs" & ns = s & "    m_earliestTime = callTime" & ns = s & "    m_originalTime = m_earliestTime" & ns = s & "End Sub" & ns = s & "Public Function Self() As TimerContainer" & ns = s & "    Set Self = Me" & ns = s & "End Function" & ns = s & "Public Property Get hWnd() As LongPtr" & ns = s & "    hWnd = m_hWnd" & ns = s & "End Property" & ns = s & "Public Property Get EventID() As LongPtr" & ns = s & "    EventID = m_nIDEvent" & ns = s & "End Property" & ns = s & "Public Property Get ID() As String" & ns = s & "    ID = m_id" & ns = s & "End Property" & ns = s & "Public Property Get Delay() As Long" & ns = s & "    Delay = m_delayMs" & ns = s & "End Property" & ns = s & "Public Property Get EarliestTime() As Date" & ns = s & "    EarliestTime = m_earliestTime" & ns = s & "End Property" & ns = s & "" & ns = s & "Public Sub UpdateTime()" & ns = s & "    Const msPerDay As Long = 24& * 60& * 60& * 1000&" & ns = s & "    Dim daysDelay As Double" & ns = s & "    Dim skipCount As Long" & ns = s & "    '" & ns = s & "    daysDelay = m_delayMs / msPerDay" & ns = s & "    skipCount = Int((NowMSec - m_originalTime) / daysDelay)" & ns = s & "    m_earliestTime = m_originalTime + (skipCount + 1) * daysDelay" & ns = s & "End Sub"TimerContainerCode = sEnd FunctionPrivate Function AppTimersCode() As StringDim s As StringConst n As String = vbNewLines = s & "Option Explicit" & ns = s & "" & ns = s & "Private m_bookTimers As Collection" & ns = s & "" & ns = s & "Private Sub Class_Initialize()" & ns = s & "    Set m_bookTimers = New Collection" & ns = s & "End Sub" & ns = s & "" & ns = s & "Private Sub Class_Terminate()" & ns = s & "    Set m_bookTimers = Nothing" & ns = s & "End Sub" & ns = s & "" & ns = s & "Public Sub Add(ByVal bTimers As BookTimers)" & ns = s & "    On Error Resume Next" & ns = s & "    m_bookTimers.Remove bTimers.ID" & ns = s & "    On Error GoTo 0" & ns = s & "    m_bookTimers.Add bTimers, bTimers.ID" & ns = s & "End Sub" & ns = s & "" & ns = s & "Public Function CanPost() As Boolean" & ns = s & "    Dim bt As BookTimers" & ns = s & "    For Each bt In m_bookTimers" & ns = s & "        If Not bt.CanPost Then Exit Function" & ns = s & "    Next bt" & ns = s & "    CanPost = True" & ns = s & "End Function" & ns = s & "" & ns = s & "Public Sub CheckRefs()" & ns = s & "    Dim bt As BookTimers" & ns = s & "    For Each bt In m_bookTimers" & ns = s & "        If bt.RefsCount = 3 Then" & ns = s & "            m_bookTimers.Remove bt.ID" & ns = s & "            bt.KillBookTimer" & ns = s & "        End If" & ns = s & "    Next bt" & ns = s & "End Sub" & ns = s & "" & ns = s & "Public Function Count() As Long" & ns = s & "    Count = m_bookTimers.Count" & ns = s & "End Function" & ns = s & "" & ns = s & "Public Function PopIfNeeded() As Boolean" & ns = s & "    Dim bt As BookTimers" & ns = s & "    Dim minBT As BookTimers" & ns = s & "    '" & ns = s & "    For Each bt In m_bookTimers" & ns = s & "        If minBT Is Nothing Then" & ns = s & "            If bt.Count > 0 Then Set minBT = bt" & ns = s & "        Else" & ns = s & "            If bt.Count > 0 Then" & ns = s & "                If bt.EarliestTime < minBT.EarliestTime Then" & ns = s & "                    Set minBT = bt" & ns = s & "                End If" & ns = s & "            End If" & ns = s & "        End If" & ns = s & "    Next bt" & ns = s & "    If minBT Is Nothing Then" & ns = s & "        PopIfNeeded = False" & ns = s & "    Else" & ns = s & "        PopIfNeeded = minBT.PopIfNeeded()" & ns = s & "    End If" & ns = s & "End Function"AppTimersCode = sEnd FunctionPrivate Function BookTimersCode() As StringDim s As StringConst n As String = vbNewLines = s & "Option Explicit" & ns = s & "" & ns = s & "#If VBA7 Then" & ns = s & "    Private Declare PtrSafe Sub CopyMemory Lib ""kernel32"" Alias ""RtlMoveMemory"" (Destination As Any, Source As Any, ByVal Length As LongPtr)" & ns = s & "    Private Declare PtrSafe Function IsWindow Lib ""user32"" (ByVal hWnd As LongPtr) As Long" & ns = 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" & ns = s & "#Else" & ns = s & "    Private Declare Sub CopyMemory Lib ""kernel32"" Alias ""RtlMoveMemory"" (Destination As Any, Source As Any, ByVal Length As Long)" & ns = s & "    Private Declare Function IsWindow Lib ""user32"" (ByVal hWnd As Long) As Long" & ns = 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" & ns = s & "#End If" & ns = s & "" & ns = s & "#If Win64 Then" & ns = s & "    Private Const PTR_SIZE As Long = 8" & ns = s & "#Else" & ns = s & "    Private Const PTR_SIZE As Long = 4" & ns = s & "#End If" & ns = s & "" & ns = s & "Private m_canPost As Boolean" & ns = s & "Private m_id As String" & ns = s & "Private m_refCount As Variant" & ns = s & "Private m_timers As Collection" & ns = s & "Private m_tProc As LongPtr" & ns = s & "" & ns = s & "Public Sub Init(ByVal bookID As String, ByVal tProc As LongPtr)" & ns = s & "    m_id = bookID" & ns = s & "    m_tProc = tProc" & ns = s & "End Sub" & ns = s & "" & ns = s & "Private Sub Class_Initialize()" & ns = s & "    Set m_timers = New Collection" & ns = s & "    SetRefCount" & ns = s & "    m_canPost = True" & ns = s & "End Sub" & ns = s & "" & ns = s & "Private Sub Class_Terminate()" & ns = s & "    Set m_timers = Nothing" & ns = s & "    On Error Resume Next" & ns = s & "    DeleteSetting ""SafeTimers"", m_id" & ns = s & "    On Error GoTo 0" & ns = s & "End Sub" & ns = s & "" & ns = s & "Private Sub SetRefCount()" & ns = s & "    Const VT_BYREF As Long = &H4000" & ns = s & "    Dim iUnk As IUnknown: Set iUnk = Me" & ns = s & "    m_refCount = ObjPtr(iUnk) + PTR_SIZE" & ns = s & "    CopyMemory m_refCount, vbLong + VT_BYREF, 2" & ns = s & "End Sub" & ns = s & "" & ns = s & "Public Property Get RefsCount() As Long" & ns = s & "    RefsCount = GetLongByRef(m_refCount)" & ns = s & "End Property" & ns = s & "Private Function GetLongByRef(ByRef v As Variant) As Long" & ns = s & "    GetLongByRef = v" & ns = s & "End Function" & ns = s & "" & ns = s & "Public Function Count() As Long" & ns = s & "    Count = m_timers.Count" & ns = s & "End Function" & ns = s & "" & ns = s & "Public Property Get ID() As String" & ns = s & "    ID = m_id" & ns = s & "End Property" & ns = s & "" & ns = s & "Public Function Self() As BookTimers" & ns = s & "    Set Self = Me" & ns = s & "End Function" & ns = s & "" & ns = s & "Public Property Get CanPost() As Boolean" & ns = s & "    If Not m_canPost Then" & ns = s & "        m_canPost = (GetSetting(""SafeTimers"", m_id, ""CanPost"") = ""True"")" & ns = s & "        If m_canPost Then" & ns = s & "            Dim lostID As String" & ns = s & "            lostID = GetSetting(""SafeTimers"", m_id, ""LostID"")" & ns = s & "            If LenB(lostID) > 0 Then" & ns = s & "                DeleteTimer lostID" & ns = s & "                DeleteSetting ""SafeTimers"", m_id, ""LostID""" & ns = s & "            End If" & ns = s & "        End If" & ns = s & "    End If" & ns = s & "    CanPost = m_canPost" & ns = s & "End Property" & ns = s & "" & ns = s & "Public Property Get EarliestTime() As Date" & ns = s & "    EarliestTime = m_timers(1).EarliestTime" & ns = s & "End Property" & ns = s & "" & ns = s & "Public Function AddTimer(ByVal hWnd As LongPtr _" & ns = s & "                       , ByVal nIDEvent As LongPtr _" & ns = s & "                       , ByVal sID As String _" & ns = s & "                       , ByVal delayMs As Long) As Boolean" & ns = s & "    DeleteTimer sID" & ns = s & "    With New TimerContainer" & ns = s & "        Const msPerDay As Long = 24& * 60& * 60& * 1000&" & ns = s & "        Dim nextRun As Date: nextRun = NowMSec() + delayMs / msPerDay" & ns = s & "        '" & ns = s & "        .Init hWnd, nIDEvent, sID, delayMs, nextRun" & ns = s & "        InsertTimer .Self" & ns = s & "    End With" & ns = s & "    AddTimer = True" & ns = s & "End Function" & ns = s & "" & ns = s & "Public Function DeleteTimer(ByVal sID As String) As Boolean" & ns = s & "    On Error Resume Next" & ns = s & "    m_timers.Remove sID" & ns = s & "    DeleteTimer = (Err.Number = 0)" & ns = s & "    On Error GoTo 0" & ns = s & "End Function" & ns = s & "" & ns = s & "Public Function DeleteAllTimers() As Boolean" & ns = s & "    Set m_timers = New Collection" & ns = s & "    DeleteAllTimers = True" & ns = s & "End Function" & ns = s & "" & ns = s & "Private Sub InsertTimer(ByRef container As TimerContainer)" & ns = s & "    Dim tc As TimerContainer" & ns = s & "    Dim i As Long: i = 1" & ns = s & "    '" & ns = s & "    For Each tc In m_timers" & ns = s & "        If tc.EarliestTime > container.EarliestTime Then Exit For" & ns = s & "        i = i + 1" & ns = s & "    Next tc" & ns = s & "    If m_timers.Count = 0 Or i > m_timers.Count Then" & ns = s & "        m_timers.Add Item:=container, Key:=container.ID" & ns = s & "    Else" & ns = s & "        m_timers.Add Item:=container, Key:=container.ID, Before:=i" & ns = s & "    End If" & ns = s & "End Sub" & ns = s & "" & ns = s & "Public Function PopIfNeeded() As Boolean" & ns = s & "    Const WM_TIMER As Long = &H113" & ns = s & "    Dim tc As TimerContainer: Set tc = m_timers(1)" & ns = s & "    '" & ns = s & "    If tc.EarliestTime > NowMSec() Then Exit Function" & ns = s & "    If Not IsIDEReady() Then Exit Function" & ns = s & "    '" & ns = s & "    m_timers.Remove 1" & ns = s & "    If PostMessage(tc.hWnd, WM_TIMER, tc.EventID, m_tProc) = 0& Then" & ns = s & "        If IsWindow(tc.hWnd) = 0& Then Exit Function" & ns = s & "    End If" & ns = s & "    m_canPost = False" & ns = s & "    PopIfNeeded = True" & ns = s & "    '" & ns = s & "    tc.UpdateTime" & ns = s & "    InsertTimer tc" & ns = s & "End Function" & ns = s & "" & ns = s & "Public Sub KillBookTimer()" & ns = s & "    Const WM_TIMER As Long = &H113" & ns = s & "    Dim rHWnd As LongPtr: rHWnd = GetReadyHWnd()" & ns = s & "    Dim tID As LongPtr: tID = VBA.Int(m_id)" & ns = s & "    '" & ns = s & "    Do While IsWindow(rHWnd)" & ns = s & "        If IsIDEReady() Then" & ns = s & "            If PostMessage(rHWnd, WM_TIMER, tID, m_tProc) <> 0& Then Exit Do" & ns = s & "        End If" & ns = s & "        Sleep 1" & ns = s & "    Loop" & ns = s & "End Sub"BookTimersCode = sEnd 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 ExplicitPrivate Type POINTAPI    x As Long    y As LongEnd TypePrivate Type MSG    hWnd As LongPtr    wMsg As Long    wParam As LongPtr    lParam As LongPtr    wTime As Long    pt As POINTAPIEnd 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 IfPrivate m_msg As MSGPrivate m_bookID As StringPublic 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 = bookIDEnd SubPrivate 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 ExplicitPrivate Const FIXED_ID As LongPtr = 5Private m_dynamicID As LongPtrPublic Sub DemoMain()    SetTimer ThisWorkbook.Windows(1).hWnd, FIXED_ID, 20, AddressOf TimerProc    m_dynamicID = SetTimer(0, 0, 50, AddressOf TimerProc)End SubPrivate 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 SelectEnd SubPrivate 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 SubPrivate 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!

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 aWM_DESTROY message to a userform. Seehere. The above is now purely an exercise in how to work from a remote application instance and get somewhat reliable timer functionality without crashes.

• \$\begingroup\$"... 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 forEnableOfficeVBOM - I believe in some version including mine, you have toopen the macro security in order for Excel to open/register that VBOM is now enabled. Alternatively, would it be better to useSaveCopyAs()?\$\endgroup\$

  Sancarn

  – Sancarn

  2023-02-08 16:37:01 +00:00

  CommentedFeb 8, 2023 at 16:37
• \$\begingroup\$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 aWM_DESTROY posted to a form. Seehere. 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.\$\endgroup\$

  Cristian Buse

  – Cristian Buse

  2023-02-09 09:39:23 +00:00

  CommentedFeb 9, 2023 at 9:39
• \$\begingroup\$@Sancarn Thanks for theEnableOfficeVBOM note - I will keep that in mind if I ever need it. UsingSaveCopyAs 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!\$\endgroup\$

  Cristian Buse

  – Cristian Buse

  2023-02-09 09:40:35 +00:00

  CommentedFeb 9, 2023 at 9:40
• 1
  \$\begingroup\$@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\$\endgroup\$

  Greedo

  – Greedo

  2023-02-09 10:02:57 +00:00

  CommentedFeb 9, 2023 at 10:02
• 2
  \$\begingroup\$@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 :)\$\endgroup\$

  Sancarn

  – Sancarn

  2023-02-09 14:01:09 +00:00

  CommentedFeb 9, 2023 at 14:01

3 Answers3

Start asking to get answers

Find the answer to your question by asking.

Explore related questions

See similar questions with these tags.