Analog Clock displayed over worksheet made purely with APIs !

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
7,493
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 :

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 Sub
As a variation to the above, I guess placing the clock inside a modeless userform would be more practical.

Regards.
 

VoG

Legend
Joined
Jun 19, 2002
Messages
63,651
Hi Jaafar.

That's very neat :)

I confirm that it works with Excel 2007 S2 on Win XP SP2.
 

James_B

Active Member
Joined
Jun 11, 2009
Messages
447
That's a really nice piece of coding. Mucho kudos. I'm on WIN XP Excel 2003 SP too; works fine.

Tell me, where's the best place to look to get accurate API call declarations?
 

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
7,493
Office Version
2016
Platform
Windows
Thanks Peter and James for testing the code and i am glad it worked on other systems too.

Tell me, where's the best place to look to get accurate API call declarations?
I use the website allapai.net and the MSDN documentation plus the api viewer that you can google and download for free rom the net.

regards.
 

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
7,493
Office Version
2016
Platform
Windows
Re: Analog Clock displayed over worksheet made purely with APIs ! ( UPDATE )

Hi all.

Here is an improvement on the previous Clock. This new clock is in fact a modeless userform in disguise.

The advantage it has over the previous one is that it doesn't have to be redrawn each time a worksheet is scrolled or a workbook window is moved hence no flickering takes place. - Also,the Clock can now be dragged around the screen with the mouse plus the background can be given a colour among other things.

WorkBook Example.

Proceedings:

1- Place this in a Standard module :

Code:
Option Explicit
 
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
 
Private Type POINTAPI
    x As Long
    y 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 FindWindow Lib "user32" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) 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 SetWindowRgn Lib "user32" _
(ByVal hwnd As Long, _
ByVal hRgn As Long, _
ByVal bRedraw As Long) As Long
 
Private Declare Function GetWindowLong Lib "user32" _
Alias "GetWindowLongA" _
(ByVal hwnd As Long, _
ByVal nIndex As Long) As Long
 
Private Declare Function SetWindowLong Lib "user32" _
Alias "SetWindowLongA" _
(ByVal hwnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
 
Private Declare Function DrawMenuBar Lib "user32" _
(ByVal hwnd 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 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 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 SetPixel Lib "gdi32" _
(ByVal hdc As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal crColor 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 GetWindowDC Lib "user32.dll" _
(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 SendMessage Lib "user32" _
Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
 
Private Declare Sub ReleaseCapture Lib "user32" ()
 
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 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 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 Declare Sub Sleep Lib "kernel32.dll" _
(ByVal dwMilliseconds As Long)
 
Private Const RDW_INVALIDATE As Long = &H1
Private Const RDW_ALLCHILDREN As Long = &H80
Private Const PS_SOLID As Long = 0
Private Const DT_CENTER As Long = &H1
 
Private Const GWL_STYLE As Long = (-16)
Private Const WS_CAPTION As Long = &HC00000
 
Private Const WM_NCLBUTTONDOWN As Long = &HA1
Private Const HTCAPTION As Long = 2
 
Private Const PI  As Single = 3.14159265358979
Private Const Rads  As Single = PI / 180
 
Private tR As RECT
 
Private ofrm As UserForm
Private objCmb As CommandBar
 
Private lfrmHwnd As Long
Private lDC As Long
Private lTimerID As Long
Private lRadius1 As Long
Private lRadius2 As Long
Private lRadius3 As Long
Private lRadius4 As Long
Private X1 As Long
Private Y1 As Long
 
Private Sub RunClock()
 
    Call CreateClock
    Call UpdateClock
 
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 * 85 / 100
 
 
    lhRng = CreateEllipticRgn _
    (X1 - lRadius3, Y1 - lRadius3, X1 + lRadius3, Y1 + lRadius3)
 
    RedrawWindow lfrmHwnd, 0, lhRng, RDW_INVALIDATE
 
    DoEvents
 
    'Seconds.
    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))
 
    'Minutes.
    MoveToEx lDC, X1, Y1, tPt
 
    lhRPen = CreatePen(PS_SOLID, 3, vbBlack)
 
    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
 
    'Hours.
    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
    ReleaseDC 0, lDC
 
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
 
    Dim p As POINTAPI
    Dim rct As RECT
 
    lDC = GetWindowDC(lfrmHwnd)
 
 
    X1 = (UserForm1.Width / 2)
    Y1 = (UserForm1.Height / 2)
 
 
    lRadius1 = (UserForm1.Width / 2) - 13
    lRadius2 = lRadius1 * 80 / 100
 
 
    SetBkMode lDC, 1
    Call CreateFont(lDC, True)
 
    For lAngle = 0 To 359
 
        For i = 6 To 10
 
            X2 = (lRadius1 + i) * (Sin(lAngle * Rads))
            Y2 = (lRadius1 + i) * (Cos(lAngle * Rads))
            SetPixel lDC, X2 + X1, Y2 + Y1, vbBlack
 
        Next i
 
        X2 = (lRadius1) * (Sin(lAngle * Rads))
        Y2 = (lRadius1) * (Cos(lAngle * Rads))
        SetPixel lDC, X2 + X1, Y2 + Y1, vbBlack
 
 
        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 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
 
Sub FormSetUp(frm As UserForm1)
 
    Dim lHr As Long, IOldStyle As Long, INewStyle As Long
    Dim IOldExStyle As Long
 
    Set ofrm = frm
   lfrmHwnd = FindWindow(vbNullString, frm.Caption)
   frm.BackColor = RGB(200, 250, 150)
    frm.Width = 150
    frm.Height = 150
'
    'Create rightclick close menu
    On Error Resume Next
    CommandBars("GlassPopUp").Delete
    Set objCmb = Application.CommandBars.Add(Position:=msoBarPopup)
    With objCmb
        objCmb.Name = "GlassPopUp"
        With .Controls.Add(msoControlButton)
            .Caption = "CloseMe"
            .OnAction = "CloseClock"
        End With
    End With
    On Error GoTo 0
 
    frm.MousePointer = fmMousePointerSizeAll
    IOldStyle = GetWindowLong(lfrmHwnd, GWL_STYLE)
    INewStyle = IOldStyle And Not WS_CAPTION
    SetWindowLong lfrmHwnd, GWL_STYLE, INewStyle
    DrawMenuBar lfrmHwnd
    lHr = CreateEllipticRgn(0, 0, frm.Width, frm.Height)
    SetWindowRgn lfrmHwnd, lHr, True
 
    frm.Hide
    lTimerID = SetTimer(0, 0, 1000, AddressOf RunClock)
    Sleep 1000
    frm.Show vbModeless
 
End Sub
 
Sub RlsCapture()
 
        Call ReleaseCapture
        SendMessage lfrmHwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0
 
End Sub
 
Sub ShowPopUp()
 
    objCmb.ShowPopUp
 
End Sub
 
Sub CloseClock()
 
    KillTimer 0, lTimerID
    Unload ofrm
 
End Sub

2- Add a UserForm to the project and place this code in its module :
(leave its default name UserForm1)

Code:
Option Explicit
 
Private Sub UserForm_Initialize()
 
    Call FormSetUp(Me)
 
End Sub
 
Private Sub UserForm_MouseDown _
(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal x As Single, ByVal y As Single)
 
    If Button = 2 Then Call ShowPopUp
 
End Sub
 
Private Sub UserForm_MouseMove _
(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal x As Single, ByVal y As Single)
 
    'move the captionless form with the mouse
     If Button = 1 Then
        Call RlsCapture
    End If
 
End Sub

3- ... and here is how to call the AnalogClock :


Code:
Option Explicit
 
Sub ShowClock()
 
    UserForm1.Show vbModeless
 
End Sub
Regards.
 

Jon von der Heyden

MrExcel MVP, Moderator
Joined
Apr 6, 2004
Messages
10,709
Office Version
365
Platform
Windows
Hi Jafaar

using XL2007 on Win7 Ultimate... Looks good :) Userform one looks especially great!
 

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
7,493
Office Version
2016
Platform
Windows
Hi Jafaar

using XL2007 on Win7 Ultimate... Looks good :) Userform one looks especially great!
Thanks Jon for the compliment. I am re-uploading some of my workbook projects via Box.net .The workbook links were previously hosted by the annoying/slow and user unfriendly FileSharing.com file uploading site and have all long expired.
 

xanksx

Board Regular
Joined
Sep 27, 2009
Messages
52
Wow !!!
Nice work Jaafar.....!!!
Your experimenting has been really worth it !!!
 

Forum statistics

Threads
1,081,841
Messages
5,361,630
Members
400,642
Latest member
tekster23

Some videos you may like

This Week's Hot Topics

  • populate from drop list with multiple tables
    Hi All, i have a drop list that displays data, what i want is when i select one of those from the list to populate text from different tables on...
  • Find list of words from sheet2 in sheet1 before a comma and extract text vba
    Hi Friends, Trying to find the solution on my task. But did not find suitable one to the need. Here is my query and sample file with details...
  • Dynamic Formula entry - VBA code sought
    Hello, really hope one of you experts can help with this - i've spent hours on this and getting no-where. .I have a set of data (more rows than...
  • Listbox Header
    Have a named range called "AccidentsHeader" Within my code I have: [CODE]Private Sub CommandButton1_Click() ListBox1.RowSource =...
  • Complex Heat Map using conditional formatting
    Good day excel world. I have a concern. Below link have a list of countries that carries each country unique data. [URL...
  • Conditional formatting
    Hi good morning, hope you can help me please, I have cells P4:P54 and if this cell is equal to 1 then i want row O to say "Fully Utilised" and to...
Top