Analog Clock displayed over worksheet made purely with APIs !

[Jaafar Tribak]

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 :

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 Sub

As a variation to the above, I guess placing the clock inside a modeless userform would be more practical.

Regards.

 

[Dan_W]

I downloaded this but haven't had a chance to try it yet and haven't looked at the code either, but am looking forward to over the weekend. The menu looks great too, btw - is that a CommandBar popup? Something about yours looks 'better' than the normal commandbar but I can't put my finger on what/why....

 

[Dan_W]

Also, I had started to respond to your post 34 above, but life got in the way Sorry. The short version =

- Thank you very much for GetwindowDc explanation - makes perfect sense.

- Re: GdipSetSmoothingMode - youre absolutely right, i didnt see that.

- hDC - I still haven't properly wrapped my head around it all, but i suspect i will eventually. Thank you.

- AutoRedraw - My other reply discussed this a bit more. Also, I find the best way to avoid subclassing is to do what i do ... which is tk completely fail to grasp the fundamentals of subclassing altogether ... that way you're never in danger of ever deciding to implement it...

 

[Jaafar Tribak]

@Dan_W

The menu looks great too, btw - is that a CommandBar popup?

It is a context menu created with the CreatePopupMenu\AppendMenu\SetMenuItemBitmaps apis . This gives me more flexibility and worked better while the timer is active.

I think that the lack of AutoRedraw Property in office forms makes rendering images to any window DC almost useless whether you BitBlt, Alphablend or even if you use the StdPicture Render Method. The rendered image will be erased when the window receives the WM_PAINT message. You can clearly see this happening when moving the window partly offscreen and then moving it back onscreen. The only remedy I now of is to handle the WM_PAINT with subclassing or to use the UpdateLayeredWindow api.

Regards.

 

[Dan_W]

You're absolutely right - and it's been difficult to deal with generally, but my approach to-date in terms of studying GDI/GDI+/APIs is to (1) read the code that you produce (thank you so very much, btw), and (2) practice by porting over VB6 programs. On the second point, I've been focusing on the games/graphics projects from the PlanetSourceCode collection that have been salvaged by the VB6 community and uploaded onto Github. Based on that, I've been working on my vbaPictureBox class (designed as a drop-in class to mimic VB6 PictureBox). I learnt double buffering through a VBAccelerator article (here), and it was there that I saw that this method was essentially what the VB6 PictureBox does with AutoRedraw. As you say, the rendered image will be erased, which is annoying but generally doesn't seem to come up alot with Game projects, at least, because they tend to do animation or constantly redraw to a timer - which is the other control I've tried to mimic with a class (I'll include the pseudo-'timer control' class in the animated GIF workbook).

Two example projects using the current version of my vbaPictureBox thingy is set out below - along with the original code.

Original

(Apologies - if the animated GIF doesn't display, you can see it here)

Please disregard the shoddy collision detection, etc. It's still a work-in-progress.

Original

 

[Dan_W]

I've tried reuploading the GIF, and it seems to be working now...

The GIF encoding appears to have done something odd with the coloring of the balls...

 

[Jaafar Tribak]

Hi Dan_W

The projects you are working on look great... Game oriented programming is not something that I ever considered and looks way over my head. But I am sure I can pick bits and pieces of code here and there and learn how to adapt some of them to vba if required\applicable.

I learnt double-buffering long time ago and I have used it in many codes I posted here over the years. It is great for rendering flicker-free images to a window DC.

Thanks for posting your work in progress. I am sure we could learn from it and good luck with your endeavors!