Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,596
- Office Version
- 2016
- Platform
- Windows
This code uses API functions.If you try it , please save your work first Hi all,
How to show a clock in a worksheet Cell is a question frequently asked.
Although, one could use the Ontime Method or use an API timer to update the time in the Cell, unfortunatly, both technics have some main drawbacks such as the clock doesn't update if the worksheet is in edit mode or if the user is selecting a range . Also, the Undo functionality is lost.
Here, I have used a different approach ( or a trick I should say ) by creating a Static Window, adjusting some of its Styles, resizing it to fit an accomodating Cell and finally placing it over that Cell so it looks as if its the Cell itsef !
This is by no means a perfect solution but at least, it overcomes the two main problems mentioned above because now, the repeating code happens in a different window from XL.
When the size of the underlying Cell is changed the clock will adjust automatically to reflect the change. The same happens if the worksheet Zoom has changed or the worksheet is scrolled.
The only thing that I haven't managed to do is to automatically be able to change the Clock formatting if the underlying Cell's formatting changes. This needs some more difficult Subclassing work and I am not quite there yet.
Here is a download demo :http://www.savefile.com/files/4303471
Here is the Code behind this Cell Clock : ( Place it in a Standard Module and run the Test routine )
Code:
Option Explicit
Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) 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 Declare Function SetWindowPos Lib "user32" _
(ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, _
ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags 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 GetWindowRect Lib "user32" _
(ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetActiveWindow Lib "user32" () As Long
Private Declare Function SetWindowText Lib "user32" _
Alias "SetWindowTextA" _
(ByVal hwnd As Long, ByVal lpString As String) As Long
Private Declare Function DestroyWindow Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function CreateWindowEx Lib "user32" _
Alias "CreateWindowExA" (ByVal dwExStyle As Long, _
ByVal lpClassName As String, ByVal lpWindowName _
As String, ByVal dwStyle As Long, ByVal x As Long, _
ByVal y As Long, ByVal nWidth As Long, _
ByVal nHeight As Long, ByVal hWndParent As Long, _
ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function ShowWindow Lib "user32" _
(ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Const WS_EX_NOACTIVATE = &H8000000
Private Const GWL_EXSTYLE = (-20)
Private Const WS_EX_TOOLWINDOW = &H80&
Private Const WS_CHILD = &H40000000
Private Const SS_CENTER = &H1
Private Const SW_HIDE = &H0
Private Const SW_NORMAL = 1
Private tRngRect As RECT
Private tRngNewDims As RECT
Private lngTimerID As Long
Private hWndStatic As Long
Private lngPrevProc As Long
Private lngWndXL As Long
Private objTargetCell As Range
'_________________________________________________________________________________________
Private Sub Create_Clock(Cell As Range)
'\ store the clock cell in a variable
Set objTargetCell = Cell
'\ get the clock cell dims in Pixels
tRngRect = GetNewRangeRect(Cell)
'\ get XL window handle
lngWndXL = FindWindow("XLMAIN", Application.Caption)
'\ create a Static window and adjust its Styles and position so
'\ it looks as if it is a cell
With tRngRect
hWndStatic = CreateWindowEx(WS_EX_NOACTIVATE + WS_EX_TOOLWINDOW, "STATIC", _
vbNullString, SS_CENTER + WS_CHILD, .Left + 1, .Top + 1, (.Right - .Left) - 2, _
(.Bottom - .Top) - 2, GetDesktopWindow, 0, 0, 0)
End With
'\ if success, start the timer.
If hWndStatic > 0 Then
lngTimerID = SetTimer(0, 0, 1, AddressOf TimerCallBack)
End If
End Sub
'____________________________________________________________________________________________
Private Sub TimerCallBack()
On Error Resume Next
Static tRngPrevDims As RECT
Static lngPrev_VScroll As Long
Static lngPrev_HScroll As Long
Static lngPrev_Zoom As Long
Dim strTime As String
'\ show Clock only if XL is active
If GetActiveWindow = lngWndXL And ActiveSheet Is objTargetCell.Parent Then
ShowWindow hWndStatic, SW_NORMAL
With tRngNewDims
.Bottom = objTargetCell.Top + objTargetCell.Height
.Left = objTargetCell.Left
.Right = objTargetCell.Left + objTargetCell.Width
.Top = objTargetCell.Top
End With
'\ if the clock cell has changed of location or size
'\ then adjust its dimensions to fit the undelying cell
If RectHasChanged(tRngPrevDims, tRngNewDims) Then
UpdateClockWindow objTargetCell
End If
'\ strore oldold dims for next round comparison
tRngPrevDims = tRngNewDims
'\ check if the user has scrolled the sheet
'\ if so, adjust the dims of the underlying cell
If Application.ActiveWindow.ScrollRow <> lngPrev_VScroll Or _
Application.ActiveWindow.ScrollColumn <> lngPrev_HScroll _
Then
UpdateClockWindow objTargetCell
End If
'\ stroe the old window scroll values for next round
lngPrev_VScroll = Application.ActiveWindow.ScrollRow
lngPrev_HScroll = Application.ActiveWindow.ScrollColumn
'\ again, check for a zoom change
'\ if the zoom has changed, adjust the underlying cell dims
If Application.ActiveWindow.Zoom <> lngPrev_Zoom Then
UpdateClockWindow objTargetCell
End If
'\ store new zoom for next time round
lngPrev_Zoom = Application.ActiveWindow.Zoom
strTime = Format(Now, "HH:MM:SS")
SetWindowText hWndStatic, strTime
Else
'\ if a different app is active or a different sheet
'\ hide the clock.
ShowWindow hWndStatic, SW_HIDE
End If
End Sub
' *************************** Supporting Routines ********************************
Private Function RectHasChanged(tOldRect As RECT, tNewRect As RECT) As Boolean
With tOldRect
RectHasChanged = (.Top <> tNewRect.Top Or .Left <> tNewRect.Left _
Or .Right <> tNewRect.Right Or .Bottom <> tNewRect.Bottom)
End With
End Function
'_________________________________________________________________________________________
Private Function GetNewRangeRect(rng As Range) As RECT
Dim tWindowRect As RECT
Dim lngXLDesk As Long
Dim lngXLChart As Long
Dim objChart As ChartObject
Set objChart = ActiveSheet.ChartObjects.Add(0, 0, 0, 0)
With objChart
.Top = rng.Top
.Left = rng.Left
.Height = rng.Height
.Width = rng.Width
.Activate
.Delete
End With
lngXLDesk = FindWindowEx(lngWndXL, 0&, "XLDESK", vbNullString)
lngXLChart = FindWindowEx(lngXLDesk, 0&, "EXCELE", vbNullString)
GetWindowRect lngXLChart, tWindowRect
GetNewRangeRect = tWindowRect
End Function
'________________________________________________________________________________
Private Sub RedimClock(tNewDim As RECT)
With tNewDim
SetWindowPos hWndStatic, 0, .Left + 1, .Top + 1, _
(.Right - .Left) - 2, (.Bottom - .Top) - 2, 0
End With
End Sub
'_________________________________________________________________________________
Private Sub UpdateClockWindow(rng As Range)
'\ repositionne the clock cell
tRngRect = GetNewRangeRect(rng)
Call RedimClock(tRngRect)
End Sub
'_________________________________________________________________________________
Sub Destroy_Control()
'\\CleanUp
DestroyWindow hWndStatic
KillTimer 0, lngTimerID
Set objTargetCell = Nothing
End Sub
'_________________________________________________________________________________
'Run this procedure
Sub Test()
If Not CBool(IsWindow(hWndStatic)) Then
Call Create_Clock(Sheet1.Range("B10"))
Else
MsgBox "Clock already on display !", vbCritical
End If
End SubNote : This won't work with XL97 as it uses the AddressOf operator.
Any feedback much appreciated.
Regards.
