Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,621
- Office Version
- 2016
- Platform
- Windows
Hi all.
I've been experimenting with some GDI APIs to create an analog clock and this is what i've come up with so far. - Not exactly a very useful thing but was interesting to code and it is an alternative to the known clock made of an XY chart.
Tested on one PC only running WIN XP Excel 2003 SP3. I hope it works on different machines too.
See here a WorkBook Demo.
In a Standard Module :
As a variation to the above, I guess placing the clock inside a modeless userform would be more practical.
Regards.
I've been experimenting with some GDI APIs to create an analog clock and this is what i've come up with so far. - Not exactly a very useful thing but was interesting to code and it is an alternative to the known clock made of an XY chart.
Tested on one PC only running WIN XP Excel 2003 SP3. I hope it works on different machines too.
See here a WorkBook Demo.
In a Standard Module :
Code:
Option Explicit
Private Type POINTAPI
x As Long
Y As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As String * 1
lfUnderline As String * 1
lfStrikeOut As String * 1
lfCharSet As String * 1
lfOutPrecision As String * 1
lfClipPrecision As String * 1
lfQuality As String * 1
lfPitchAndFamily As String * 1
lfFaceName As String * 32
End Type
Private Declare Function GetDC Lib "user32.dll" _
(ByVal hwnd As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32.dll" _
(ByVal hdc As Long, _
ByVal nIndex As Long) As Long
Private Declare Function ReleaseDC Lib "user32" _
(ByVal hwnd As Long, _
ByVal hdc As Long) As Long
Private Declare Function SetPixel Lib "gdi32" _
(ByVal hdc As Long, _
ByVal x As Long, _
ByVal Y As Long, _
ByVal crColor As Long) As Long
Private Declare Function InvalidateRect _
Lib "user32" (ByVal hwnd As Long, _
lpRect As Long, _
ByVal bErase As Long) As Long
Private Declare Function DrawText Lib "user32" _
Alias "DrawTextA" _
(ByVal hdc As Long, _
ByVal lpStr As String, _
ByVal nCount As Long, _
lpRect As RECT, _
ByVal wFormat As Long) As Long
Private Declare Function SetRect Lib "user32" _
(lpRect As RECT, _
ByVal X1 As Long, _
ByVal Y1 As Long, _
ByVal X2 As Long, _
ByVal Y2 As Long) As Long
Private Declare Function CreateFontIndirect Lib "gdi32" _
Alias "CreateFontIndirectA" _
(lpLogFont As LOGFONT) As Long
Private Declare Function SetBkMode Lib "gdi32" _
(ByVal hdc As Long, _
ByVal nBkMode As Long) As Long
Private Declare Function LineTo Lib "gdi32" _
(ByVal hdc As Long, _
ByVal x As Long, _
ByVal Y As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" _
(ByVal hdc As Long, _
ByVal x As Long, _
ByVal Y As Long, _
lpPoint As POINTAPI) As Long
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, _
ByVal hObject As Long) As Long
Private Declare Function CreatePen Lib "gdi32" _
(ByVal nPenStyle As Long, _
ByVal nWidth As Long, _
ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Private Declare Function CreateEllipticRgn 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 GetForegroundWindow Lib "user32" () As Long
Private Declare Function FindWindow Lib "user32.dll" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function SetTimer Lib "user32.dll" _
(ByVal hwnd As Long, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32.dll" _
(ByVal hwnd As Long, _
ByVal nIDEvent As Long) As Long
Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90
Private Const PointsPerInch As Long = 72
Private Const PI As Single = 3.14159265358979
Private Const Rads As Single = PI / 180
Private Const RDW_INVALIDATE = &H1
Private Const RDW_ALLCHILDREN = &H80
Private Const PS_SOLID = 0
Private Const DT_CENTER = &H1
Private tp As POINTAPI
Private tR As RECT
Private oUpperLeftCell As Range
Private lTimerID As Long
Private X1 As Long, Y1 As Long
Private lDC As Long
Private lRadius1 As Long, lRadius2 As Long
Private lRadius3 As Long, lRadius4 As Long
Sub Test()
[COLOR=seagreen]'display the analog clock @ the
'current screen location of cell 'D10' .
[/COLOR]
ShowClock TargetCell:=Range("D10")
End Sub
Sub StopClock()
KillTimer 0, lTimerID
lTimerID = 0
End Sub
Sub HideClock()
InvalidateRect 0, 0, 0
KillTimer 0, lTimerID
lTimerID = 0
End Sub
[COLOR=seagreen]'=======================
'Main code '
'=======================[/COLOR]
Private Sub ShowClock(TargetCell As Range)
If lTimerID = 0 Then
Set oUpperLeftCell = ActiveWindow.VisibleRange.Cells(1, 1)
If Union(TargetCell, ActiveWindow.VisibleRange).Address _
<> ActiveWindow.VisibleRange.Address Then
GoTo errHandler:
End If
tp = GetRangeCenterPointInPixels(TargetCell)
lTimerID = SetTimer(0, 0, 1000, AddressOf RunClock)
End If
Exit Sub
errHandler:
MsgBox "Target Cell not visible.", vbCritical
End Sub
Private Sub RunClock()
On Error Resume Next
If GetForegroundWindow = _
FindWindow("XLMAIN", Application.Caption) Then
If ActiveWindow.VisibleRange.Cells(1, 1).Address _
<> oUpperLeftCell.Address Then
InvalidateRect 0, 0, 0
DoEvents
End If
Call CreateClock
Call UpdateClock
End If
End Sub
Private Sub CreateClock()
Dim i As Long
Dim lAngle As Long
Dim X2 As Long, Y2 As Long
Dim A2 As Long, B2 As Long
X1 = tp.x
Y1 = tp.Y
lRadius1 = 60
lRadius2 = lRadius1 * 80 / 100
lDC = GetDC(0)
SetBkMode lDC, 1
Call CreateFont(lDC, True)
For lAngle = 0 To 359
For i = 7 To 10
X2 = (lRadius1 + i) * (Sin(lAngle * Rads))
Y2 = (lRadius1 + i) * (Cos(lAngle * Rads))
SetPixel lDC, X2 + X1, Y2 + Y1, vbRed
Next i
X2 = (lRadius1) * (Sin(lAngle * Rads))
Y2 = (lRadius1) * (Cos(lAngle * Rads))
SetPixel lDC, X2 + X1, Y2 + Y1, vbRed
A2 = lRadius2 * (Sin(lAngle * Rads))
B2 = lRadius2 * (Cos(lAngle * Rads))
SetRect tR, (A2 + X1) - 5, B2 + Y1 - 5, _
A2 + X1 + 5, B2 + Y1 + 5
Select Case lAngle
Case Is = 0
DrawText lDC, "6", 1, tR, DT_CENTER
Case Is = 30
DrawText lDC, "5", 1, tR, DT_CENTER
Case Is = 60
DrawText lDC, "4", 1, tR, DT_CENTER
Case Is = 90
DrawText lDC, "3", 1, tR, DT_CENTER
Case Is = 120
DrawText lDC, "2", 1, tR, DT_CENTER
Case Is = 150
DrawText lDC, "1", 1, tR, DT_CENTER
Case Is = 180
DrawText lDC, "12", 2, tR, DT_CENTER
Case Is = 210
DrawText lDC, "11", 2, tR, DT_CENTER
Case Is = 240
DrawText lDC, "10", 2, tR, DT_CENTER
Case Is = 270
DrawText lDC, "9", 1, tR, DT_CENTER
Case Is = 300
DrawText lDC, "8", 1, tR, DT_CENTER
Case Is = 330
DrawText lDC, "7", 1, tR, DT_CENTER
End Select
Next lAngle
End Sub
Private Sub UpdateClock()
Dim tPt As POINTAPI
Dim lhRng As Long
Dim lhRPen As Long
Dim lSecond As Single
Dim lMinute As Single
Dim lHour As Single
lRadius3 = lRadius1 * 70 / 100
lRadius4 = lRadius1 * 80 / 100
lhRng = CreateEllipticRgn _
(X1 - lRadius3, Y1 - lRadius3, X1 + lRadius3, Y1 + lRadius3)
RedrawWindow 0, 0, lhRng, RDW_INVALIDATE + RDW_ALLCHILDREN
DoEvents
[COLOR=seagreen]'Seconds.
[/COLOR] MoveToEx lDC, X1, Y1, tPt
lhRPen = CreatePen(PS_SOLID, 1, vbRed)
DeleteObject SelectObject(lDC, lhRPen)
lSecond = Second(Time) * (2 * PI / 60)
LineTo lDC, X1 + ((lRadius3) * 0.85 * Sin(lSecond)), _
Y1 - ((lRadius3) * 0.85 * Cos(lSecond))
[COLOR=seagreen]'Minutes.
[/COLOR] MoveToEx lDC, X1, Y1, tPt
lhRPen = CreatePen(PS_SOLID, 2, vbRed)
DeleteObject SelectObject(lDC, lhRPen)
lMinute = (Minute(Time) + (Second(Time) / 60)) * (2 * PI / 60)
LineTo lDC, X1 + (lRadius3) * Sin(lMinute) * 0.8, _
Y1 - (lRadius3) * Cos(lMinute) * 0.8
[COLOR=seagreen]'Hours.[/COLOR]
MoveToEx lDC, X1, Y1, tPt
lhRPen = CreatePen(PS_SOLID, 4, vbBlack)
DeleteObject SelectObject(lDC, lhRPen)
lHour = (Hour(Time) + (Minute(Time) / 60)) * (2 * PI / 12)
LineTo lDC, X1 + (lRadius4) * Sin(lHour) * 0.5, _
Y1 - (lRadius4) * Cos(lHour) * 0.5
Set oUpperLeftCell = ActiveWindow.VisibleRange.Cells(1, 1)
ReleaseDC 0, lDC
End Sub
Private Function GetRangeCenterPointInPixels(rng As Range) As POINTAPI
Dim CenterX, CenterY As Double
Dim lDC As Long
On Error Resume Next
lDC = GetDC(0)
CenterX = rng.Left + (rng.Width / 2)
CenterY = rng.Top + (rng.Height / 2)
With GetRangeCenterPointInPixels
.x = ActiveWindow.PointsToScreenPixelsX((CenterX) * _
(GetDeviceCaps _
(lDC, LOGPIXELSX) / PointsPerInch * ActiveWindow.Zoom / 100))
.Y = ActiveWindow.PointsToScreenPixelsY((CenterY) * _
(GetDeviceCaps _
(lDC, LOGPIXELSY) / PointsPerInch * ActiveWindow.Zoom / 100))
End With
ReleaseDC 0, lDC
End Function
Private Sub CreateFont(DC As Long, Optional Bold As Boolean)
Dim uFont As LOGFONT
Dim lNewFont As Long
With uFont
.lfFaceName = "Tahoma" & Chr$(0)
.lfHeight = 12
.lfWidth = 5
.lfWeight = IIf(Bold, 900, 100)
End With
lNewFont = CreateFontIndirect(uFont)
DeleteObject (SelectObject(DC, lNewFont))
End SubAs a variation to the above, I guess placing the clock inside a modeless userform would be more practical.
Regards.
Your thoughts on any of the following is (as always) greatly appreciated:
