VERSION 5.00
Begin VB.UserControl AnalogClock 
   BorderStyle     =   1  'Fixed Single
   ClientHeight    =   885
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   1260
   ScaleHeight     =   885
   ScaleWidth      =   1260
   ToolboxBitmap   =   "AnalogClock.ctx":0000
   Begin VB.Timer tmrSecond 
      Interval        =   1000
      Left            =   0
      Top             =   0
   End
   Begin VB.Line lnMarks 
      Index           =   11
      X1              =   1080
      X2              =   1080
      Y1              =   360
      Y2              =   765
   End
   Begin VB.Line lnMarks 
      Index           =   10
      X1              =   1035
      X2              =   1035
      Y1              =   360
      Y2              =   765
   End
   Begin VB.Line lnMarks 
      Index           =   9
      X1              =   990
      X2              =   990
      Y1              =   360
      Y2              =   765
   End
   Begin VB.Line lnMarks 
      Index           =   8
      X1              =   945
      X2              =   945
      Y1              =   360
      Y2              =   765
   End
   Begin VB.Line lnMarks 
      Index           =   7
      X1              =   900
      X2              =   900
      Y1              =   360
      Y2              =   765
   End
   Begin VB.Line lnMarks 
      Index           =   6
      X1              =   855
      X2              =   855
      Y1              =   360
      Y2              =   765
   End
   Begin VB.Line lnMarks 
      Index           =   5
      X1              =   810
      X2              =   810
      Y1              =   360
      Y2              =   765
   End
   Begin VB.Line lnMarks 
      Index           =   4
      X1              =   765
      X2              =   765
      Y1              =   360
      Y2              =   765
   End
   Begin VB.Line lnMarks 
      Index           =   3
      X1              =   720
      X2              =   720
      Y1              =   360
      Y2              =   765
   End
   Begin VB.Line lnMarks 
      Index           =   2
      X1              =   675
      X2              =   675
      Y1              =   360
      Y2              =   765
   End
   Begin VB.Line lnMarks 
      Index           =   1
      X1              =   630
      X2              =   630
      Y1              =   360
      Y2              =   765
   End
   Begin VB.Line lnMarks 
      Index           =   0
      X1              =   585
      X2              =   585
      Y1              =   360
      Y2              =   765
   End
   Begin VB.Line lnSecond 
      X1              =   1125
      X2              =   495
      Y1              =   270
      Y2              =   270
   End
   Begin VB.Line lnMinute 
      BorderWidth     =   2
      X1              =   1125
      X2              =   495
      Y1              =   180
      Y2              =   180
   End
   Begin VB.Line lnHour 
      BorderWidth     =   3
      X1              =   1125
      X2              =   495
      Y1              =   90
      Y2              =   90
   End
End
Attribute VB_Name = "AnalogClock"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

Private Pi As Double
Private Deg2Rad As Double

    Public Enum interFX_AnaClock_BackStyle
    Clock_Transparent = 0
    Clock_Opaque = 1
    End Enum

    Public Enum interFX_AnaClock_BorderStyle
    Clock_None = 0
    Clock_Fixed = 1
    End Enum


'Default Property Values:
Const m_def_PointerHourLength = 60
Const m_def_PointerMinuteLength = 80
Const m_def_PointerSecondLength = 100
Const m_def_TicksLength = 5
Const m_def_UseInternalDate = True
Const m_def_CurrentDate As Date = "00:00:00"

'Property Variables:
Dim m_PointerHourLength As Byte
Dim m_PointerMinuteLength As Byte
Dim m_PointerSecondLength As Byte
Dim m_TicksLength As Byte
Dim m_UseInternalDate As Byte
Dim m_CurrentDate As Date

'Event Declarations:
Event Click() 'MappingInfo=UserControl,UserControl,-1,Click
Attribute Click.VB_Description = "Occurs when the user presses and then releases a mouse button over an object."
Event DblClick() 'MappingInfo=UserControl,UserControl,-1,DblClick
Attribute DblClick.VB_Description = "Occurs when the user presses and releases a mouse button and then presses and releases it again over an object."
Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseDown
Attribute MouseDown.VB_Description = "Occurs when the user presses the mouse button while an object has the focus."
Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseMove
Attribute MouseMove.VB_Description = "Occurs when the user moves the mouse."
Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseUp
Attribute MouseUp.VB_Description = "Occurs when the user releases the mouse button while an object has the focus."
Event Timer() 'MappingInfo=tmrSecond,tmrSecond,-1,Timer
Attribute Timer.VB_Description = "Occurs when a preset interval for a Timer control has elapsed."
Private Sub DrawLines()
On Error GoTo DrawLines_Err

Dim W As Long, H As Long, TM As Integer, M As Integer, S As Integer
Dim XOver As Integer, YOver As Integer
Dim Counter As Integer

W = (UserControl.ScaleWidth - 1) / 2
H = (UserControl.ScaleHeight - 1) / 2


    For Counter = 1 To 12
    lnMarks(Counter - 1).X1 = W + W * Sin(Counter * 30 * Deg2Rad)
    lnMarks(Counter - 1).Y1 = H + H * Cos(Counter * 30 * Deg2Rad)
    lnMarks(Counter - 1).X2 = W + W * ((100 - m_TicksLength) / 100) * Sin(Counter * 30 * Deg2Rad)
    lnMarks(Counter - 1).Y2 = H + H * ((100 - m_TicksLength) / 100) * Cos(Counter * 30 * Deg2Rad)
    Next Counter

Exit Sub
DrawLines_Err:
Exit Sub

End Sub
Private Sub DrawPointers()
On Error GoTo DrawPointers_Err

Dim W As Long, H As Long, TM As Integer, M As Integer, S As Integer

W = (UserControl.ScaleWidth - 1) / 2
H = (UserControl.ScaleHeight - 1) / 2

    If m_UseInternalDate Then
    S = Second(Now)
    M = Minute(Now)
    TM = Hour(Now) * 60 + M
    
    Else
    S = Second(m_CurrentDate)
    M = Minute(m_CurrentDate)
    TM = Hour(m_CurrentDate) * 60 + M
    
    End If

SetLineAngle lnHour, 360 * (TM / 720), W * (m_PointerHourLength / 100), H * (m_PointerHourLength / 100)
SetLineAngle lnMinute, 6 * M, W * (m_PointerMinuteLength / 100), H * (m_PointerMinuteLength / 100)
SetLineAngle lnSecond, 6 * S, W * (m_PointerSecondLength / 100), H * (m_PointerSecondLength / 100)

Exit Sub
DrawPointers_Err:
Exit Sub

End Sub
Private Sub SetLineAngle(ByVal Obj As Line, ByVal Angle As Single, ByVal Width As Integer, ByVal Height As Integer)
On Error GoTo SetLineAngle_Err

Dim XOver As Integer, YOver As Integer

XOver = Width * Sin((Angle) * Deg2Rad)
YOver = Height * Cos((Angle) * Deg2Rad)

    With Obj
    .X2 = .X1 + XOver
    .Y2 = .Y1 - YOver
    End With

Exit Sub
SetLineAngle_Err:
Exit Sub

End Sub
Public Property Get UseInternalDate() As Boolean
On Error GoTo Get_Err

UseInternalDate = m_UseInternalDate

Exit Property
Get_Err:
Exit Property

End Property
Public Property Get CurrentDate() As Date
On Error GoTo Get_Err

CurrentDate = m_CurrentDate

Exit Property
Get_Err:
Exit Property

End Property
Private Sub tmrSecond_Timer()
On Error GoTo tmrSecond_Timer_Err

RaiseEvent Timer

    If Not m_UseInternalDate Then
    m_CurrentDate = DateAdd("s", 1, m_CurrentDate)
    PropertyChanged "CurrentDate"
    End If

DrawPointers

Exit Sub
tmrSecond_Timer_Err:
Exit Sub

End Sub
Private Sub UserControl_Initialize()
On Error GoTo UserControl_Initialize_Err

Pi = 4 * Atn(1)
Deg2Rad = Pi / 180
DrawLines

Exit Sub
UserControl_Initialize_Err:
Exit Sub

End Sub
Private Sub UserControl_Resize()
On Error GoTo UserControl_Resize_Err

    With UserControl
    .lnHour.X1 = .ScaleWidth / 2
    .lnHour.Y1 = .ScaleHeight / 2
    .lnMinute.X1 = .ScaleWidth / 2
    .lnMinute.Y1 = .ScaleHeight / 2
    .lnSecond.X1 = .ScaleWidth / 2
    .lnSecond.Y1 = .ScaleHeight / 2
    End With

DrawLines
DrawPointers

Exit Sub
UserControl_Resize_Err:
Exit Sub

End Sub
Public Property Get BackStyle() As interFX_AnaClock_BackStyle
Attribute BackStyle.VB_Description = "Indicates whether a Label or the background of a Shape is transparent or opaque."
On Error GoTo Get_Err

BackStyle = UserControl.BackStyle

Exit Property
Get_Err:
Exit Property

End Property
Public Property Let BackStyle(ByVal New_BackStyle As interFX_AnaClock_BackStyle)
On Error GoTo Let_Err

UserControl.BackStyle() = New_BackStyle
    PropertyChanged "BackStyle"

Exit Property
Let_Err:
Exit Property

End Property
Public Property Get BorderStyle() As interFX_AnaClock_BorderStyle
Attribute BorderStyle.VB_Description = "Returns/sets the border style for an object."
On Error GoTo Get_Err

BorderStyle = UserControl.BorderStyle

Exit Property
Get_Err:
Exit Property

End Property
Public Property Let BorderStyle(ByVal New_BorderStyle As interFX_AnaClock_BorderStyle)
On Error GoTo Let_Err

UserControl.BorderStyle() = New_BorderStyle
    PropertyChanged "BorderStyle"

Exit Property
Let_Err:
Exit Property

End Property
Private Sub UserControl_Click()
On Error GoTo UserControl_Click_Err

RaiseEvent Click

Exit Sub
UserControl_Click_Err:
Exit Sub

End Sub
Private Sub UserControl_DblClick()
On Error GoTo UserControl_DblClick_Err

RaiseEvent DblClick

Exit Sub
UserControl_DblClick_Err:
Exit Sub

End Sub
Public Property Get hDC() As Long
Attribute hDC.VB_Description = "Returns a handle (from Microsoft Windows) to the object's device context."
On Error GoTo Get_Err

hDC = UserControl.hDC

Exit Property
Get_Err:
Exit Property

End Property
Public Property Get hWnd() As Long
Attribute hWnd.VB_Description = "Returns a handle (from Microsoft Windows) to an object's window."
On Error GoTo Get_Err

hWnd = UserControl.hWnd

Exit Property
Get_Err:
Exit Property

End Property
Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error GoTo UserControl_MouseDown_Err

RaiseEvent MouseDown(Button, Shift, X, Y)

Exit Sub
UserControl_MouseDown_Err:
Exit Sub

End Sub
Public Property Get MouseIcon() As Picture
Attribute MouseIcon.VB_Description = "Sets a custom mouse icon."
On Error GoTo Get_Err

Set MouseIcon = UserControl.MouseIcon

Exit Property
Get_Err:
Exit Property

End Property
Public Property Set MouseIcon(ByVal New_MouseIcon As Picture)
On Error GoTo Set_Err

Set UserControl.MouseIcon = New_MouseIcon
    PropertyChanged "MouseIcon"

Exit Property
Set_Err:
Exit Property

End Property
Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error GoTo UserControl_MouseMove_Err

RaiseEvent MouseMove(Button, Shift, X, Y)

Exit Sub
UserControl_MouseMove_Err:
Exit Sub

End Sub
Public Property Get MousePointer() As Integer
On Error GoTo Get_Err

MousePointer = UserControl.MousePointer

Exit Property
Get_Err:
Exit Property

End Property
Public Property Let MousePointer(ByVal New_MousePointer As Integer)
Attribute MousePointer.VB_Description = "Returns/sets the type of mouse pointer displayed when over part of an object."
On Error GoTo Let_Err

UserControl.MousePointer() = New_MousePointer
    PropertyChanged "MousePointer"

Exit Property
Let_Err:
Exit Property

End Property
Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error GoTo UserControl_MouseUp_Err

RaiseEvent MouseUp(Button, Shift, X, Y)

Exit Sub
UserControl_MouseUp_Err:
Exit Sub

End Sub
Public Property Get PointerHourWidth() As Integer
Attribute PointerHourWidth.VB_Description = "Returns or sets the width of a control's border."
On Error GoTo Get_Err

PointerHourWidth = lnHour.BorderWidth

Exit Property
Get_Err:
Exit Property

End Property
Public Property Let PointerHourWidth(ByVal New_PointerHourWidth As Integer)
On Error GoTo Let_Err

lnHour.BorderWidth() = New_PointerHourWidth
    PropertyChanged "PointerHourWidth"

Exit Property
Let_Err:
Exit Property

End Property
Public Property Get PointerMinuteWidth() As Integer
Attribute PointerMinuteWidth.VB_Description = "Returns or sets the width of a control's border."
On Error GoTo Get_Err

PointerMinuteWidth = lnMinute.BorderWidth

Exit Property
Get_Err:
Exit Property

End Property
Public Property Let PointerMinuteWidth(ByVal New_PointerMinuteWidth As Integer)
On Error GoTo Let_Err

lnMinute.BorderWidth() = New_PointerMinuteWidth
    PropertyChanged "PointerMinuteWidth"

Exit Property
Let_Err:
Exit Property

End Property
Public Property Get PointerSecondWidth() As Integer
Attribute PointerSecondWidth.VB_Description = "Returns or sets the width of a control's border."
On Error GoTo Get_Err

PointerSecondWidth = lnSecond.BorderWidth

Exit Property
Get_Err:
Exit Property

End Property
Public Property Let PointerSecondWidth(ByVal New_PointerSecondWidth As Integer)
On Error GoTo Let_Err

lnSecond.BorderWidth() = New_PointerSecondWidth
    PropertyChanged "PointerSecondWidth"

Exit Property
Let_Err:
Exit Property

End Property
Public Property Get PointerHourColor() As OLE_COLOR
Attribute PointerHourColor.VB_Description = "Returns/sets the color of an object's border."
On Error GoTo Get_Err

PointerHourColor = lnHour.BorderColor

Exit Property
Get_Err:
Exit Property

End Property
Public Property Let PointerHourColor(ByVal New_PointerHourColor As OLE_COLOR)
On Error GoTo Let_Err

lnHour.BorderColor() = New_PointerHourColor
    PropertyChanged "PointerHourColor"

Exit Property
Let_Err:
Exit Property

End Property
Public Property Get PointerMinuteColor() As OLE_COLOR
Attribute PointerMinuteColor.VB_Description = "Returns/sets the color of an object's border."
On Error GoTo Get_Err

PointerMinuteColor = lnMinute.BorderColor

Exit Property
Get_Err:
Exit Property

End Property
Public Property Let PointerMinuteColor(ByVal New_PointerMinuteColor As OLE_COLOR)
On Error GoTo Let_Err

lnMinute.BorderColor() = New_PointerMinuteColor
    PropertyChanged "PointerMinuteColor"

Exit Property
Let_Err:
Exit Property

End Property
Public Property Get PointerSecondColor() As OLE_COLOR
Attribute PointerSecondColor.VB_Description = "Returns/sets the color of an object's border."
On Error GoTo Get_Err

PointerSecondColor = lnSecond.BorderColor

Exit Property
Get_Err:
Exit Property

End Property
Public Property Let PointerSecondColor(ByVal New_PointerSecondColor As OLE_COLOR)
On Error GoTo Let_Err

lnSecond.BorderColor() = New_PointerSecondColor
    PropertyChanged "PointerSecondColor"

Exit Property
Let_Err:
Exit Property

End Property
Public Property Get TicksLength() As Byte
On Error GoTo Get_Err

TicksLength = m_TicksLength

Exit Property
Get_Err:
Exit Property

End Property
Public Property Let TicksLength(ByVal New_TicksLength As Byte)
On Error GoTo Let_Err

m_TicksLength = New_TicksLength
    DrawLines
    PropertyChanged "TicksLength"

Exit Property
Let_Err:
Exit Property

End Property
Public Property Let UseInternalDate(ByVal New_UseInternalDate As Boolean)
On Error GoTo Let_Err

m_UseInternalDate = New_UseInternalDate
    DrawLines
    PropertyChanged "UseInternalDate"

Exit Property
Let_Err:
Exit Property

End Property
Public Property Let CurrentDate(ByVal New_CurrentDate As Date)
On Error GoTo Let_Err

m_CurrentDate = New_CurrentDate
    DrawLines
    PropertyChanged "CurrentDate"

Exit Property
Let_Err:
Exit Property

End Property
Private Sub UserControl_InitProperties()
On Error GoTo UserControl_InitProperties_Err

m_TicksLength = m_def_TicksLength
    m_PointerHourLength = m_def_PointerHourLength
    m_PointerMinuteLength = m_def_PointerMinuteLength
    m_PointerSecondLength = m_def_PointerSecondLength
    m_CurrentDate = m_def_CurrentDate
    m_UseInternalDate = m_def_UseInternalDate

Exit Sub
UserControl_InitProperties_Err:
Exit Sub

End Sub
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
On Error GoTo UserControl_ReadProperties_Err

Dim Counter As Integer

    UserControl.BackStyle = PropBag.ReadProperty("BackStyle", 1)
    UserControl.BorderStyle = PropBag.ReadProperty("BorderStyle", 1)
    Set MouseIcon = PropBag.ReadProperty("MouseIcon", Nothing)
    UserControl.MousePointer = PropBag.ReadProperty("MousePointer", 0)
    lnHour.BorderWidth = PropBag.ReadProperty("PointerHourWidth", 3)
    lnMinute.BorderWidth = PropBag.ReadProperty("PointerMinuteWidth", 2)
    lnSecond.BorderWidth = PropBag.ReadProperty("PointerSecondWidth", 1)
    lnHour.BorderColor = PropBag.ReadProperty("PointerHourColor", -2147483640)
    lnMinute.BorderColor = PropBag.ReadProperty("PointerMinuteColor", -2147483640)
    lnSecond.BorderColor = PropBag.ReadProperty("PointerSecondColor", -2147483640)
    m_TicksLength = PropBag.ReadProperty("TicksLength", m_def_TicksLength)
    
        For Counter = 0 To 11
        lnMarks(Counter).BorderColor = PropBag.ReadProperty("TicksColor", -2147483640)
        Next Counter
        DrawLines
        
    m_PointerHourLength = PropBag.ReadProperty("PointerHourLength", m_def_PointerHourLength)
    m_PointerMinuteLength = PropBag.ReadProperty("PointerMinuteLength", m_def_PointerMinuteLength)
    m_PointerSecondLength = PropBag.ReadProperty("PointerSecondLength", m_def_PointerSecondLength)
    m_CurrentDate = PropBag.ReadProperty("CurrentDate", m_def_CurrentDate)
    m_UseInternalDate = PropBag.ReadProperty("UseInternalDate", m_def_UseInternalDate)
    
    UserControl.BackColor = PropBag.ReadProperty("BackColor", &H8000000F)
    lnMarks(0).BorderColor = PropBag.ReadProperty("TicksColor", -2147483640)

Exit Sub
UserControl_ReadProperties_Err:
Exit Sub

End Sub
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
On Error GoTo UserControl_WriteProperties_Err

    Call PropBag.WriteProperty("BackStyle", UserControl.BackStyle, 1)
    Call PropBag.WriteProperty("BorderStyle", UserControl.BorderStyle, 1)
    Call PropBag.WriteProperty("MouseIcon", MouseIcon, Nothing)
    Call PropBag.WriteProperty("MousePointer", UserControl.MousePointer, 0)
    Call PropBag.WriteProperty("PointerHourWidth", lnHour.BorderWidth, 3)
    Call PropBag.WriteProperty("PointerMinuteWidth", lnMinute.BorderWidth, 2)
    Call PropBag.WriteProperty("PointerSecondWidth", lnSecond.BorderWidth, 1)
    Call PropBag.WriteProperty("PointerHourLength", m_PointerHourLength, m_def_PointerHourLength)
    Call PropBag.WriteProperty("PointerMinuteLength", m_PointerMinuteLength, m_def_PointerMinuteLength)
    Call PropBag.WriteProperty("PointerSecondLength", m_PointerSecondLength, m_def_PointerSecondLength)
    Call PropBag.WriteProperty("PointerHourColor", lnHour.BorderColor, -2147483640)
    Call PropBag.WriteProperty("PointerMinuteColor", lnMinute.BorderColor, -2147483640)
    Call PropBag.WriteProperty("PointerSecondColor", lnSecond.BorderColor, -2147483640)
    Call PropBag.WriteProperty("TicksLength", m_TicksLength, m_def_TicksLength)
    Call PropBag.WriteProperty("TicksColor", lnMarks(0).BorderColor, -2147483640)
    Call PropBag.WriteProperty("TicksColor", lnMarks(0).BorderColor, -2147483640)
    Call PropBag.WriteProperty("CurrentDate", m_CurrentDate, m_def_CurrentDate)
    Call PropBag.WriteProperty("UseInternalDate", m_UseInternalDate, m_def_UseInternalDate)
    

Exit Sub
UserControl_WriteProperties_Err:
Exit Sub

End Sub
Public Property Get PointerHourLength() As Byte
On Error GoTo Get_Err

PointerHourLength = m_PointerHourLength

Exit Property
Get_Err:
Exit Property

End Property
Public Property Let PointerHourLength(ByVal New_PointerHourLength As Byte)
On Error GoTo Let_Err

m_PointerHourLength = New_PointerHourLength
    PropertyChanged "PointerHourLength"

Exit Property
Let_Err:
Exit Property

End Property
Public Property Get PointerMinuteLength() As Byte
On Error GoTo Get_Err

PointerMinuteLength = m_PointerMinuteLength

Exit Property
Get_Err:
Exit Property

End Property
Public Property Let PointerMinuteLength(ByVal New_PointerMinuteLength As Byte)
On Error GoTo Let_Err

m_PointerMinuteLength = New_PointerMinuteLength
    PropertyChanged "PointerMinuteLength"

Exit Property
Let_Err:
Exit Property

End Property
Public Property Get PointerSecondLength() As Byte
On Error GoTo Get_Err

PointerSecondLength = m_PointerSecondLength

Exit Property
Get_Err:
Exit Property

End Property
Public Property Let PointerSecondLength(ByVal New_PointerSecondLength As Byte)
On Error GoTo Let_Err

m_PointerSecondLength = New_PointerSecondLength
    PropertyChanged "PointerSecondLength"

Exit Property
Let_Err:
Exit Property

End Property
Public Property Get BackColor() As OLE_COLOR
Attribute BackColor.VB_Description = "Returns/sets the background color used to display text and graphics in an object."
On Error GoTo Get_Err

BackColor = UserControl.BackColor

Exit Property
Get_Err:
Exit Property

End Property
Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
On Error GoTo Let_Err

UserControl.BackColor() = New_BackColor
    PropertyChanged "BackColor"

Exit Property
Let_Err:
Exit Property

End Property
Public Property Get TicksColor() As OLE_COLOR
Attribute TicksColor.VB_Description = "Returns/sets the color of an object's border."
On Error GoTo Get_Err

TicksColor = lnMarks(0).BorderColor

Exit Property
Get_Err:
Exit Property

End Property
Public Property Let TicksColor(ByVal New_TicksColor As OLE_COLOR)
On Error GoTo Let_Err

Dim Counter As Integer

    For Counter = 0 To 11
    lnMarks(Counter).BorderColor = New_TicksColor
    Next Counter
    PropertyChanged "TicksColor"
    

Exit Property
Let_Err:
Exit Property

End Property
