CodeItBetter Programming Another VB Programming Blog

'Miscellaneous - How to make an Analog Clock
Option Explicit
 
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 Boolean) As Long
 
Private Declare Function ReleaseCapture Lib "user32" () 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 Const HTCAPTION = 2
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const WM_SYSCOMMAND = &H112
 
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" _
    (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As RECT, _
    ByVal fuWinIni As Long) As Long
Private Const SPI_GETWORKAREA = 48
 
Private Const PI = 3.14159265
Private Const GRAB_RADIUS = 3
 
Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal H As Long, _
    ByVal W As Long, ByVal E As Long, ByVal O As Long, ByVal W As Long, ByVal I As Long, _
    ByVal u As Long, ByVal S As Long, ByVal C As Long, ByVal OP As Long, ByVal CP As Long, _
    ByVal Q As Long, ByVal PAF As Long, ByVal F As String) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
 
' Put the form in the lower right corner.
Private Sub PositionForm()
    Dim wa_info As RECT
    Dim wa_wid As Single
    Dim wa_hgt As Single
 
    If SystemParametersInfo(SPI_GETWORKAREA, 0, wa_info, 0) <> 0 Then
        ' We got the work area bounds.
        ' Center the form in the work area.
        wa_wid = ScaleX(wa_info.Right, vbPixels, vbTwips)
        wa_hgt = ScaleY(wa_info.Bottom, vbPixels, vbTwips)
    Else
        ' We did not get the work area bounds.
        ' Center the form on the whole screen.
        wa_wid = Screen.Width
        wa_hgt = Screen.Height
    End If
 
    ' Position the form.
    Me.Move wa_wid - Width, wa_hgt - Height
End Sub
 
' Center the form
Private Sub CenterForm(ByVal frm As Form)
    Dim wa_info As RECT
    Dim wa_wid As Single
    Dim wa_hgt As Single
    Dim wa_left As Single
    Dim wa_top As Single
 
    If SystemParametersInfo(SPI_GETWORKAREA, 0, wa_info, 0) <> 0 Then
        ' We got the work area bounds.
        ' Center the form in the work area.
        wa_wid = ScaleX(wa_info.Right, vbPixels, vbTwips)
        wa_hgt = ScaleY(wa_info.Bottom, vbPixels, vbTwips)
        wa_left = ScaleX(wa_info.Left, vbPixels, vbTwips)
        wa_top = ScaleY(wa_info.Top, vbPixels, vbTwips)
    Else
        ' We did not get the work area bounds.
        ' Center the form on the whole screen.
        wa_wid = Screen.Width
        wa_hgt = Screen.Height
    End If
 
    ' Center the form.
    frm.Move (wa_wid - Width + wa_left) / 2, (wa_hgt - Height + wa_top) / 2
End Sub
 
' Draw the clock's face without hands.
Private Sub DrawFace()
    Dim hrgn As Long
    Dim xoff As Single
    Dim yoff As Single
    Dim cx As Single
    Dim cy As Single
    Dim theta As Single
    Dim dtheta As Single
    Dim I As Integer
    Dim x1 As Single
    Dim y1 As Single
    Dim x2 As Single
    Dim y2 As Single
    Dim txt As String
    Dim new_font As Long
    Dim old_font As Long
 
    ' ControlBox = False
    ' ShowInTaskbar = False
    Caption = ""
    BorderStyle = vbBSNone
    AutoRedraw = True
    ScaleMode = vbPixels
 
    ' Make an elliptical region centered
    ' over the drawing area.
    xoff = (ScaleX(Width, vbTwips, vbPixels) - ScaleWidth) / 2
    yoff = (ScaleY(Height, vbTwips, vbPixels) - ScaleHeight) / 2
    hrgn = CreateEllipticRgn(xoff, yoff, xoff + ScaleWidth + 1, yoff + ScaleHeight + 1)
    SetWindowRgn hwnd, hrgn, False
 
    ' Draw the clock face.
    cx = (ScaleWidth - 1) / 2
    cy = (ScaleHeight - 1) / 2
    FillStyle = vbFSSolid
    Circle (cx, cy), GRAB_RADIUS
    FillStyle = vbFSTransparent
 
    ' Draw the tic marks and numerals.
    dtheta = PI / 30
    theta = -10 * dtheta
    For I = 0 To 59
        ' Draw the tic marks.
        x1 = cx + cx * Cos(theta)
        y1 = cy + cy * Sin(theta)
        If I Mod 5 = 0 Then
            ' Label the digit.
            txt = Format$(I \ 5 + 1)
 
            ' Create a rotated font.
            new_font = CustomFont(16, 0, (3 * PI / 2 - theta) * 1800 / PI, 0, 700, False, _
                False, False, "Times New Roman")
            old_font = SelectObject(hdc, new_font)
 
            ' Draw the text.
            ' Find the point lined up along the tic mark.
            x2 = cx + (cx - 1) * Cos(theta) * 0.95
            y2 = cy + (cy - 1) * Sin(theta) * 0.95
 
            ' Offset by distance TextWidth/2 rotated
            ' so the text is centered.
            CurrentX = x2 + TextWidth(txt) / 2 * Sin(theta)
            CurrentY = y2 - TextWidth(txt) / 2 * Cos(theta)
            ForeColor = RGB(0, 0, 128)
            Print txt
            ForeColor = vbBlack
 
            ' Restore the original font and delete the
            ' new font to free resources.
            SelectObject hdc, old_font
            DeleteObject new_font
 
            x2 = cx + cx * Cos(theta) * 0.9
            y2 = cy + cy * Sin(theta) * 0.9
        Else
            x2 = cx + cx * Cos(theta) * 0.95
            y2 = cy + cy * Sin(theta) * 0.95
        End If
        Line (x1, y1)-(x2, y2)
        theta = theta + dtheta
    Next I
 
    ' Make the image permanent.
    Picture = Image
End Sub
 
' Make a customized font and return its handle.
Private Function CustomFont(ByVal hgt As Long, ByVal wid As Long, ByVal escapement As Long, _
    ByVal orientation As Long, ByVal wgt As Long, ByVal is_italic As Long, _
    ByVal is_underscored As Long, ByVal is_striken_out As Long, ByVal face As String) As Long
    Const CLIP_LH_ANGLES = 16   ' Needed for tilted fonts.

    CustomFont = CreateFont(hgt, wid, escapement, orientation, wgt, is_italic, is_underscored, _
        is_striken_out, 0, 0, CLIP_LH_ANGLES, 0, 0, face)
End Function
 
' Draw the clock's hands.
Private Sub DrawHands()
    Const HOUR_R = 0.3
    Const MIN_R = 0.5
    Const SEC_R = 0.75
 
    Dim cx As Single
    Dim cy As Single
    Dim theta As Single
    Dim x2 As Single
    Dim y2 As Single
    Dim time_now As Date
 
    ' Draw the clock face.
    cx = (ScaleWidth - 1) / 2
    cy = (ScaleHeight - 1) / 2
 
    ' Clear the previous hands.
    Cls
 
    ' Draw the hour hand.
    time_now = Time
    theta = -PI / 2 + 4 * PI * (CSng(time_now))
    x2 = cx + cx * Cos(theta) * HOUR_R
    y2 = cy + cy * Sin(theta) * HOUR_R
    DrawWidth = 3
    Line (cx, cy)-(x2, y2)
 
    ' Draw the minute hand.
    theta = -PI / 2 + PI / 30 * Minute(time_now)
    x2 = cx + cx * Cos(theta) * MIN_R
    y2 = cy + cy * Sin(theta) * MIN_R
    DrawWidth = 2
    Line (cx, cy)-(x2, y2)
 
    ' Draw the second hand.
    theta = -PI / 2 + PI / 30 * Second(time_now)
    x2 = cx + cx * Cos(theta) * SEC_R
    y2 = cy + cy * Sin(theta) * SEC_R
    DrawWidth = 1
    Line (cx, cy)-(x2, y2)
End Sub
 
' Return True if the mouse is near the center of the form.
Private Function OverCenter(ByVal X As Single, ByVal Y As Single) As Boolean
    Dim cx As Single
    Dim cy As Single
    Dim dx As Single
    Dim dy As Single
 
    ' See if the point is close enough to the center.
    cx = (ScaleWidth - 1) / 2
    cy = (ScaleHeight - 1) / 2
    dx = cx - X
    dy = cy - Y
    OverCenter = (dx * dx + dy * dy <= GRAB_RADIUS * GRAB_RADIUS)
End Function
 
Private Sub Form_Load()
    ' Draw the face without the hands.
    DrawFace
    ' Put the form in the lower right corner.
    PositionForm
End Sub
 
' If the mouse is at the center of the clock, let the user move it.
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If OverCenter(X, Y) Then
        ' Move the form.
        ReleaseCapture
        SendMessage hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
    ElseIf Button = vbRightButton Then
        ' Display the popup.
        PopupMenu mnuPopup
    End If
End Sub
 
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If OverCenter(X, Y) Then
        If MousePointer <> vbCrosshair Then MousePointer = vbCrosshair
    Else
        If MousePointer <> vbDefault Then MousePointer = vbDefault
    End If
End Sub
 
Private Sub mnuPopupExit_Click()
    Unload Me
End Sub
 
' Draw the clock's hands.
Private Sub tmrTick_Timer()
    DrawHands
End Sub