Problems with running Clock in worksheet cell

[Jaafar Tribak]

Greetings,

I've searched the board and this question has been raised before however, unless i overlooked it, no solution has been provided for the two following main problems caused by having a running clock in a worksheet cell :
1-Clock stops updating while excel is in EDIT MODE
2-Excel losing the UNDO functionality.

Anybody seen these issues addressed somewhere?

Regards.

 

[Jaafar Tribak]

Hi Tushar. Nice to have you on this thread.

I never thought updating the workbook Styles would trigger a sheet calculation ! -Nice.

That said, this conditionnal formatting/styles approach you provided in the link doesn't solve the main problem we are discussing here namely keeping the clock updating (or in the case of flashing, keeping the cell flashing ) while in edit mode.

One thought. What if you are editing the cell that is being recalced? Does that affect Excel's behavior?

No. I would just call the TimerProc as follows , although i don't see the need for wanting to edit the cell containing the clock.

Private Sub TimerProc()
 
    On Error Resume Next
    oTargetCell.FormulaR1C1 = "=TEXT(NOW(),""hh:mm:ss"")"
    oTargetCell.Calculate
 
End Sub

Regards.

 

[Jaafar Tribak]

WorkBook demo

Inspired by tushar's CF approach , I have put together this new code that will ensure the flashing of the cell is not interrupted while the worksheet is on Edit Mode.

In fact, this method also works when a modal excel dialog window is currently displayed on the forground (such as the Format Dialog) . It also works while dragging cells and more importantly doesn't cause the loss of the UNDO command !

The trick is to not diectly manipulate the cell object inside the timer procedure. Instead , the update of the cell is done via the RedrawWindow API.

To avoid flickering of the screen after each Paint, i have limited the painting to the region that exactly superposes the boundaries of the flashing cell.This is done via the CreateRectRgn API.

In a Standard Module : ( call the StartFlashing routine to flash cell A1 )

Option Explicit
 
Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

Private Declare Function GetDC Lib "user32" _
(ByVal HWnd As Long) As Long
 
Private Declare Function ReleaseDC Lib "user32" _
(ByVal HWnd As Long, _
ByVal hdc As Long) As Long
 
Private Declare Function GetDeviceCaps Lib "gdi32" _
(ByVal hdc As Long, _
ByVal nIndex As Long) As Long

Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long

Private Declare Function CreateRectRgn Lib "gdi32" _
(ByVal X1 As Long, _
ByVal Y1 As Long, _
ByVal X2 As Long, _
ByVal Y2 As Long) As Long
 
Private Declare Function RedrawWindow Lib "user32" _
(ByVal HWnd As Long, _
ByVal lprcUpdate As Long, _
ByVal hrgnUpdate As Long, _
ByVal fuRedraw 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
 
Private Declare Function KillTimer Lib "user32" _
(ByVal HWnd As Long, _
ByVal nIDEvent As Long) As Long

Private Const RDW_INVALIDATE = &H1
Private Const RDW_ALLCHILDREN = &H80
 
Private oTargetCell As Range
Private lTimerId As Long, lhwnd As Long
 
 
Sub StartFlashing()
 
    AddFlashingEffect Sheets(1).Range("a1")
    
End Sub
 
Sub StopFlashing()
 
    RemoveFlashingEffect Sheets(1).Range("a1")
    
End Sub
 
 
 
Private Sub AddFlashingEffect(Cell As Range)
 
    Const lTimeInterv As Long = 1000
 
    lhwnd = FindWindow("XLMAIN", Application.Caption)
    
    Set oTargetCell = Cell
    
    With oTargetCell
        .FormatConditions.Delete
        .FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=MOD(SECOND(NOW()),2)=1"
        .FormatConditions(1).Interior.ColorIndex = 4
    End With
    
    lTimerId = SetTimer(0, 0, lTimeInterv, AddressOf TimerProc)
 
End Sub
 
Private Sub RemoveFlashingEffect(Cell As Range)
 
    KillTimer 0, lTimerId
    Cell.FormatConditions.Delete
 
End Sub
 
Private Sub TimerProc(ByVal HWnd As Long, _
ByVal uMsg As Long, _
ByVal nIDEvent As Long, _
ByVal dwTimer As Long)
 
    Dim hRng As Long
    
    On Error Resume Next
    
    With GetRangeRect(oTargetCell)
        hRng = CreateRectRgn(0, 0, .Right, .Bottom)
    End With
    
    RedrawWindow lhwnd, 0, hRng, RDW_INVALIDATE + RDW_ALLCHILDREN
 
End Sub
 
Private Function ScreenDPI(bVert As Boolean) As Long
 
    Static lDPI(1), lDC
    
    If lDPI(0) = 0 Then
        lDC = GetDC(0)
        lDPI(0) = GetDeviceCaps(lDC, 88)
        lDPI(1) = GetDeviceCaps(lDC, 90)
        lDC = ReleaseDC(0, lDC)
    End If
    
    ScreenDPI = lDPI(Abs(bVert))
    
End Function

Private Function PTtoPX _
(Points As Single, bVert As Boolean) As Long
 
    PTtoPX = Points * ScreenDPI(bVert) / 72
  
End Function
 
Private Function GetRangeRect(ByVal rng As Range) As RECT
 
    Dim OWnd  As Window
    
    Set OWnd = rng.Parent.Parent.Windows(1)
    
    With rng
        GetRangeRect.Left = PTtoPX(.Left * OWnd.Zoom / 100, 0) _
        + OWnd.PointsToScreenPixelsX(0)
        GetRangeRect.Top = PTtoPX(.Top * OWnd.Zoom / 100, 1) _
        + OWnd.PointsToScreenPixelsY(0)
        GetRangeRect.Right = PTtoPX(.Width * OWnd.Zoom / 100, 0) _
        + GetRangeRect.Left
        GetRangeRect.Bottom = PTtoPX(.Height * OWnd.Zoom / 100, 1) _
        + GetRangeRect.Top
    End With
 
End Function

Regards.

 

[ahazeman]

Forgot the workbook demo : see here

Regards.

the file already none .. could you please share again.. thanks in advance

 

[Pinaceous]

Thank you

Jaafar Tribak!​