Right Click on cell must not stop Macro

[r1998]

Dear Friends and Respected Seniors,
I am using this VBA code to show current time every second in cell A1 of Sheet10.

Public Sub show_current_time()
Application.DisplayAlerts = False
Application.EnableAnimations = False
Application.EnableEvents = False
Sheet10.Range("A1") = Time
Application.OnTime Now + TimeValue("00:00:01"), "show_current_time"
End Sub

It works fine but if I right click on any cell in Sheet10 or in any other WorkSheet, the macro pauses; then when I press ESC or left click, the right click menu goes away and macro resumes its execution.
I have disabled Application.DisplayAlerts, Application.EnableAnimations and Application.EnableEvents but still macro pauses when I right click.
I dont want macro to pause when I right click on any cell in any WorkSheet.
One solution is to disable right clicking in Sheet10, but I have many worksheets and I dont want to disable right clicking in all worksheets
Can anyone please kindly help and guide me
Awaiting your replies.
Thank you.

 

[bobsan42]

It seems like Excel is not executing the scheduled code while it is waiting for some input (not only right-clicking).
i think it is in the definition of Application.OnTime - sub will not run while excel is busy.

 

[bobsan42]

Further on the subject - I did some digging and I ran into this:
https://github.com/VBA-tools/VBA-Web/issues/88
http://www.vbforums.com/showthread.php?527281-VB6-SelfTimer-class-module-2008-06-15

based on these links I came up with something. Still not perfect, but will certainly work while Right-click menu is visible. However while a cell is edited or while you're changing row/column size the timer will freeze (the timer code is suspended).

To implement it:
Open VBE, create a class module and name it SelfTimer. Paste the following code in it:

'*************************************************************************************************
'* SelfTimer 1.1 - Timer class module
'* ----------------------------------
'* By Vesa Piittinen aka Merri, http://vesa.piittinen.name/ <vesa@piittinen.name>
'*
'* LICENSE
'* -------
'* http://creativecommons.org/licenses/by-sa/1.0/fi/deed.en
'*
'* Terms: 1) If you make your own version, share using this same license.
'*        2) When used in a program, mention my name in the program's credits.
'*        3) Free for commercial and non-commercial usage.
'*        4) Use at your own risk. No support guaranteed.
'*
'* REQUIREMENTS
'* ------------
'* Huh what? Just this one class module. No extra files required.
'*
'* HOW TO ADD TO YOUR PROGRAM
'* --------------------------
'* 1) Copy SelfTimer.cls to your project folder.
'* 2) In your project, add SelfTimer.cls
'*
'* VERSION HISTORY
'* ---------------
'* Version 1.1 (2008-06-23)
'* - Simplified even further thanks to Paul's improved code. All Sc functions removed, everything
'*   SelfCallback related is in Private_Start and Private_Stop.
'*
'* Version 1.0 (2008-06-15)
'* - It was requested to simplify SelfCallback code and make a one class module timer at VBForums.
'*   I renamed and cleaned up the code to fit my own coding style. Good or bad, a matter of taste.
'*
'* CREDITS
'* -------
'* Paul Caton and LaVolpe for their work on SelfSub, SelfHook and SelfCallback
'*************************************************************************************************
Option Explicit


' events
Public Event Timer(ByVal Seconds As Currency)


' public properties
Private m_Enabled As Boolean
Private m_Interval As Long


' private variables
Private m_Start As Currency
Private m_TimerID As Long
Private m_TimerProc As Long


Private Declare Sub GetMem4LngToCur Lib "msvbvm60" Alias "GetMem4" (ByRef LngVar As Long, CurVar As Currency)
Private Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long


' the following are the requirements for SelfCallback
Private Declare Sub GetMem1 Lib "msvbvm60" (ByVal Addr As Long, RetVal As Byte)
Private Declare Sub GetMem4 Lib "msvbvm60" (ByVal Addr As Long, RetVal As Long)
Private Declare Function GetModuleHandleA Lib "kernel32" (ByVal lpModuleName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function IsBadCodePtr Lib "kernel32" (ByVal lpfn As Long) As Long
Private Declare Sub PutMem2 Lib "msvbvm60" (ByVal Addr As Long, ByVal NewVal As Integer)
Private Declare Sub RtlMachineCodeCopy Lib "kernel32" Alias "RtlMoveMemory" (Destination As Long, Source As MachineCode, ByVal Length As Long)
Private Declare Function VirtualAlloc Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Private Declare Function VirtualFree Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long


' self-documentation: less comments and constants
Private Type MachineCode        ' 37 * 4 = 148 bytes
    ' thunk
    OwnerPtr As Long            ' 0
    CallbackAddress As Long     ' 1
    API_EbMode As Long          ' 2
    API_IsBadCodePtr As Long    ' 3
    API_KillTimer As Long       ' 4
    ' code
    MC1(5 To 5) As Long         ' 5
    AllocatedDataPtr As Long    ' 6
    MC2(7 To 17) As Long        ' 7 - 17
    ParamCount As Long          ' 18
    MC3(19 To 35) As Long       ' 19 - 35
    Ordinal As Long             ' 36
End Type


Public Property Get Enabled() As Boolean
    Enabled = m_Enabled
End Property
Public Property Let Enabled(ByVal NewValue As Boolean)
    m_Enabled = NewValue
    ' we can call these both; the order is important, of course
    Private_Stop
    Private_Start
End Property
Public Property Get Interval() As Long
    Interval = m_Interval
End Property
Public Property Let Interval(ByVal NewValue As Long)
    ' validate range
    If NewValue >= 0 Then
        ' kill existing timer?
        Private_Stop
        ' update value
        m_Interval = NewValue
        ' start timer
        Private_Start
    End If
End Property
Private Sub Private_Start()
    Dim bytValue As Byte, bytSignature As Byte, lngA As Long
    Dim lngAddress As Long, lngMethod As Long, lngObject As Long
    Dim lngCallback As Long, lngMCmem As Long, udtMC As MachineCode


    ' index of ordinal (always 1 in this class, the last procedure)
    Const Ordinal As Long = 1
    ' number of parameters (for TimerProc this is always 4, thus this is a constant)
    Const ParamCount As Long = 4


    ' start only if enabled, interval is set and we have not done this already
    If m_TimerProc = 0 And m_Enabled And m_Interval <> 0 Then
        ' get object pointer
        lngObject = ObjPtr(Me)
        ' get VTable address
        GetMem4 lngObject, lngAddress
        ' Class method (see SelfSub code for non-Class values)
        lngAddress = lngAddress + &H1C&
        ' get method pointer
        GetMem4 lngAddress, lngMethod
        ' get method signature byte: &H33 = pseudo-code, &HE9 = native code
        GetMem1 lngMethod, bytSignature
        ' next VTable address
        lngAddress = lngAddress + 4&
        ' try a "reasonable" amount of VTable entries
        For lngA = 511 To 1 Step -1
            ' get method pointer
            GetMem4 lngAddress, lngMethod
            ' see if we are out of VTable (I use "Then Else" because True conditions are faster)
            If IsBadCodePtr(lngMethod) = 0& Then Else Exit For
            ' get method signature byte
            GetMem1 lngMethod, bytValue
            ' if it is invalid we are out of VTable
            If bytValue = bytSignature Then Else Exit For
            ' try next one
            lngAddress = lngAddress + 4&
        Next lngA
        ' if lngA = 0 we looped through the entire loop; if that did not happen, we get the pointer
        If lngA Then GetMem4 lngAddress - (Ordinal * 4&), lngCallback
        ' verify we got the TimerProc callback address of ordinal 1
        If lngCallback Then
            ' allocate executable memory
            lngMCmem = VirtualAlloc(0, LenB(udtMC), &H1000&, &H40&) 'Length, MEM_COMMIT, PAGE_RWX
            ' verify we got it
            If lngMCmem Then
                With udtMC
                    ' thunk
                    .OwnerPtr = lngObject
                    .CallbackAddress = lngCallback
''''''''''''                    If App.LogMode = 0 Then
''''''''''''                        ' for IDE safety, store the EbMode function address in the thunk data
''''''''''''                        .API_EbMode = GetProcAddress(GetModuleHandleA("vba6"), "EbMode")
''''''''''''                    End If
                    .API_IsBadCodePtr = GetProcAddress(GetModuleHandleA("kernel32"), "IsBadCodePtr")
                    .API_KillTimer = GetProcAddress(GetModuleHandleA("user32"), "KillTimer")
                    ' actual machine code
                    .MC1(5&) = &HBB60E089:    .MC2(7&) = &H73FFC589
                    .MC2(8&) = &HC53FF04:     .MC2(9&) = &H59E80A74
                    .MC2(10) = &HE9000000:    .MC2(11) = &H30&
                    .MC2(12) = &H87B81:       .MC2(13) = &H75000000
                    .MC2(14) = &H9090902B:    .MC2(15) = &H42DE889
                    .MC2(16) = &H50000000:    .MC2(17) = &HB9909090
                    .MC3(19) = &H90900AE3:    .MC3(20) = &H8D74FF
                    .MC3(21) = &H9090FAE2:    .MC3(22) = &H53FF33FF
                    .MC3(23) = &H90909004:    .MC3(24) = &H2BADC261
                    .MC3(25) = &H3D0853FF:    .MC3(26) = &H1&
                    .MC3(27) = &H23DCE74:     .MC3(28) = &H74000000
                    .MC3(29) = &HAE807:       .MC3(30) = &H90900000
                    .MC3(31) = &H4589C031:    .MC3(32) = &H90DDEBFC
                    .MC3(33) = &HFF0C75FF:    .MC3(34) = &H53FF0475
                    .MC3(35) = &HC310&
                    ' settings within the code
                    .AllocatedDataPtr = lngMCmem
                    .Ordinal = Ordinal
                    .ParamCount = ParamCount
                    PutMem2 VarPtr(.MC3(24)) + 2&, CInt(ParamCount * 4&)
                End With
                ' copy thunk code to executable memory
                RtlMachineCodeCopy ByVal lngMCmem, udtMC, LenB(udtMC)
                ' remember the procedure address (add thunk offset)
                m_TimerProc = lngMCmem + &H14&
                ' now we can initialize the timer
                m_TimerID = SetTimer(0&, 0&, m_Interval, m_TimerProc)
                ' done!
                Exit Sub
            End If
        End If
        ' timer initialization failed for whatever reason, thus timer is disabled
        m_Enabled = False
    End If
End Sub
Private Sub Private_Stop()
    ' only do this if we still have the procedure
    If m_TimerProc Then
        ' kill the timer
        KillTimer 0&, m_TimerID
        ' reset id
        m_TimerID = 0
        ' free the procedure callback
        VirtualFree m_TimerProc, 0&, &H8000& 'MEM_RELEASE
        ' reset procedure pointer to prevent this getting ran twice
        m_TimerProc = 0
    End If
End Sub
Public Sub Reset()
    ' reset counter start value
    m_Start = 0
End Sub
Private Sub Class_Initialize()
    ' initial values: we have it enabled but we have no interval
    m_Enabled = True
    m_Interval = 0
End Sub
Private Sub Class_Terminate()
    Private_Stop
End Sub
' must be the last procedure, ordinal [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1]#1[/URL] !
Private Function TimerProc(ByVal hWnd As Long, ByVal tMsg As Long, ByVal TimerID As Long, ByVal tickCount As Long) As Long
    Dim curCounter As Currency
    ' copy Long to Currency
    GetMem4LngToCur tickCount, curCounter
    ' see if start has been initialized (it never will be zero)
    If m_Start > 0 Then
        ' calculate seconds since beginning
        RaiseEvent Timer(curCounter * 10 - m_Start)
    Else
        ' just remember the start time and start from zero
        m_Start = curCounter * 10
        RaiseEvent Timer(0)
    End If
    ' WHATEVER YOU DO, DO NOT CALL Private_Stop FROM HERE!
End Function

Go back to the sheet where you want to show the time and create an ActiveX Command button named CommandButton1 (this is the default name).
Go back to VBE, open the sheet code module and paste the following code:

Option Explicit


Dim WithEvents tTimer As SelfTimer


Private Sub CommandButton1_Click()
    If tTimer Is Nothing Then
        Set tTimer = New SelfTimer
        tTimer.Interval = 1000 'The timer interval in miliseconds
        Me.CommandButton1.Caption = "Stop timer"
    Else
        Me.CommandButton1.Caption = "Start timer"
        Set tTimer = Nothing
    End If
End Sub


Private Sub tTimer_Timer(ByVal Seconds As Currency)
    On Error GoTo EP
    Sheet11.Range("A1").Value = Time
EP:
End Sub

Press the button to see if this works for you.

 

[r1998]

Thank you Bobsan Sir,
the above code worked perfectly
but when I switched to another sheet I got error 50290
so I made a tiny change to sub ttimer_timer

Private Sub tTimer_Timer(ByVal Seconds As Currency)   
 On Error Resume Next
 Sheet10.Range("A1").Value = Time
End Sub

Now everything works perfectly fine. Thank you.

 

[bobsan42]

Glad it worked.
One suggestion though: if not absolutely necessary maybe you wouldn't need the code running while the sheet is not visible.

And also - just in case make it like this:

[COLOR=#333333]ThisWorkbook.Sheet10.Range("A1").Value = Time[/COLOR]

 

[r1998]

Thank you Bobsan Sir,
changed code to this

ThisWorkbook.Sheets(10).Range("A1").Value = Time

Everything working perfectly. Thank you

 

[Jaafar Tribak]

The code posted by bobsan42 won't work in excel/vba unless the visual basic runtime is installed.

You could use this simpler alternative which has the added benefit of updating the cell even when excel is in edit mode

1- In a Standard Module:

Option Explicit

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If


Private oTemp As Range
 
 
Public Sub AddClock(ByVal Cell As Range)

    With Cell
        If Len(.ID) = 0 Then
            Set oTemp = Cell
            .FormulaR1C1 = "=TEXT(NOW(),""hh:mm:ss"")"
            .ID = ObjPtr(Cell)
            Call SetTimer(Application.hwnd, ObjPtr(Cell), 1000, AddressOf TimerProc)
        End If
    End With
    
End Sub
 
Public Sub RemoveClock(ByVal Cell As Range)

    With Cell
        If Len(.ID) Then
            KillTimer Application.hwnd, .ID
            .FormulaR1C1 = vbNullString
            .ID = vbNullString
        End If
    End With
    
End Sub


Private Sub TimerProc(ByVal hwnd As Long, ByVal MSG As Long, ByVal nIDEvent As Long, ByVal dwTimer As Long)

    Dim oClockCell As Range
    
    On Error Resume Next
    CopyMemory oClockCell, nIDEvent, LenB(nIDEvent)
    oClockCell.Calculate
    CopyMemory oClockCell, 0, LenB(nIDEvent)
    
End Sub

2- Then you just call it this way :

Sub CreateClock()
    AddClock Sheet1.Range("a1")
End Sub

Sub DestroyClock()
    RemoveClock Sheet1.Range("a1")
End Sub

 

[r1998]

Thank you Jaafar Tribak Sir
your code is working perfectly fine