abstimelist.ctl

Abstract TimeList Control v1.0

VERSION 5.00
Begin VB.UserControl absTimeList 
   AutoRedraw      =   -1  'True
   BackColor       =   &H00FFFFFF&
   BorderStyle     =   1  'Fixed Single
   ClientHeight    =   4935
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   3000
   PropertyPages   =   "absTimeList.ctx":0000
   ScaleHeight     =   4935
   ScaleWidth      =   3000
   ToolboxBitmap   =   "absTimeList.ctx":0021
   Begin TimeList.absPane pneTop 
      Align           =   1  'Align Top
      Height          =   375
      Left            =   0
      TabIndex        =   1
      Top             =   0
      Width           =   3000
      _ExtentX        =   5292
      _ExtentY        =   661
      BorderStyle     =   2
      ScaleHeight     =   348
      ScaleLeft       =   23
      ScaleTop        =   23
      ScaleWidth      =   2973
   End
   Begin VB.VScrollBar scroll 
      Height          =   4050
      LargeChange     =   5
      Left            =   2595
      Max             =   23
      TabIndex        =   0
      TabStop         =   0   'False
      Top             =   420
      Width           =   270
   End
End
Attribute VB_Name = "absTimeList"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Attribute VB_Ext_KEY = "PropPageWizardRun" ,"Yes"
'********************************************************************
'      NAME: Abstract Image Calendar
'   VERSION: 1.0
'   WEBSITE: http://abstractvb.com/
'
'   You may use the control for your own projects
'   but you cannot resell or redistribute this
'   control, project or any of the code without
'   the prior written consent of Abstractvb.com.
'
'   This control was written to demonstrate several
'   programming techniques and is NOT production ready.
'   If you plan on using this control in a production
'   environment you do so at your own risk.
'
'********************************************************************
Option Explicit

Public Event TimeChanged(NewTime As Date)

Enum TimeConstants
    abs12HourClock = 0
    abs24HourClock = 1
End Enum

Private Type TimeBoundingBox
    X1_00 As Single
    Y1_00 As Single
    X2_00 As Single
    Y2_00 As Single
    tX_00 As Single
    tY_00 As Single
    X1_15 As Single
    Y1_15 As Single
    X2_15 As Single
    Y2_15 As Single
    tX_15 As Single
    tY_15 As Single
    X1_30 As Single
    Y1_30 As Single
    X2_30 As Single
    Y2_30 As Single
    tX_30 As Single
    tY_30 As Single
    X1_45 As Single
    Y1_45 As Single
    X2_45 As Single
    Y2_45 As Single
    tX_45 As Single
    tY_45 As Single
    B_00 As Boolean
    B_15 As Boolean
    B_30 As Boolean
    B_45 As Boolean
    i_00 As Picture
    i_15 As Picture
    i_30 As Picture
    i_45 As Picture
    t_00 As String
    t_15 As String
    t_30 As String
    t_45 As String
End Type

Private Const LEFT_INSET As Single = 50
Private Const TOP_INSET As Single = 100
Private Const MINUTE_INSET As Single = 600
Private Const ICON_INSET As Single = 900
Private Const TEXT_INSET As Single = 1200
Private Const MINUTE_LINE_COLOR As Long = &HC0C0C0
Private Const BLOCK_SIZE As Single = 1700
Private Const MINUTE_HEIGHT As Single = 400
Private Const MIN_HEIGHT As Single = 1425
Private Const MIN_WIDTH As Single = 1560

Private mintTopHour As Integer
Private mTimeBox(24) As TimeBoundingBox
Private mdteTime As Date
Private mintCurrentIndex As Integer
Private mintCurrentMinute As Integer
Private mblnIntegralHeight As Boolean
Private msglFactor As Single
Private mintClockType As Integer

Private mlngMarkedColor As Long
Private mlngHourColor As Long
Private mlngMinuteColor As Long
Private mlngHighlightColor As Long
Private mlngHighlightTextColor As Long

Private Sub pneTop_KeyDown(KeyCode As Integer, Shift As Integer)
    Select Case KeyCode
    Case vbKeyDown
        If mintCurrentMinute = 45 Then
            If mintCurrentIndex < 23 Then
                mintCurrentMinute = 0
                mintCurrentIndex = mintCurrentIndex + 1
                
                'Scroll if going off screen
                If scroll.Value + msglFactor < mintCurrentIndex Then
                    If scroll.Value + 1 <= scroll.Max Then
                        scroll.Value = scroll.Value + 1
                    End If
                End If
            End If
        Else
            mintCurrentMinute = mintCurrentMinute + 15
        End If
        
        DrawTimeBlocks
        UserControl.Refresh
        RaiseEvent TimeChanged(mdteTime)
                        
    Case vbKeyUp
        If mintCurrentMinute = 0 Then
            If mintCurrentIndex > 0 Then
                mintCurrentMinute = 45
                mintCurrentIndex = mintCurrentIndex - 1
            
                'Scroll if going off screen
                If scroll.Value > mintCurrentIndex Then
                    If scroll.Value - 1 >= scroll.Min Then
                        scroll.Value = scroll.Value - 1
                    End If
                End If
            End If
        Else
            mintCurrentMinute = mintCurrentMinute - 15
        End If
    
        DrawTimeBlocks
        UserControl.Refresh
        RaiseEvent TimeChanged(mdteTime)
    End Select
End Sub

Private Sub scroll_Change()
    mintTopHour = scroll.Value
    DrawTimeBlocks
End Sub

Private Sub scroll_GotFocus()
    pneTop.SetFocus
End Sub

Private Sub scroll_Scroll()
    mintTopHour = scroll.Value
    DrawTimeBlocks
End Sub

Private Sub UserControl_InitProperties()
    mintCurrentIndex = 0
    mintCurrentMinute = 0
    mintTopHour = 1
    mdteTime = "12:00"
    
    UserControl.BackColor = &HFFFFFF
    UserControl.ForeColor = &H0
    mlngMarkedColor = &H0
    mlngHourColor = &H0
    mlngMinuteColor = &H808080
    mlngHighlightColor = &HFFC0C0
    mlngHighlightTextColor = &HFFFFFF
    
    mblnIntegralHeight = True
    pneTop.Caption = Extender.Name
    
End Sub

Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim i As Integer
    
    For i = 0 To 23
        If X > mTimeBox(i).X1_00 And X < mTimeBox(i).X2_00 And Y > mTimeBox(i).Y1_00 And Y < mTimeBox(i).Y2_00 Then
            mintCurrentIndex = i
            mintCurrentMinute = 0
            DrawTimeBlocks
            RaiseEvent TimeChanged(mdteTime)
            
        ElseIf X > mTimeBox(i).X1_15 And X < mTimeBox(i).X2_15 And Y > mTimeBox(i).Y1_15 And Y < mTimeBox(i).Y2_15 Then
            mintCurrentIndex = i
            mintCurrentMinute = 15
            DrawTimeBlocks
            
            RaiseEvent TimeChanged(mdteTime)
        ElseIf X > mTimeBox(i).X1_30 And X < mTimeBox(i).X2_30 And Y > mTimeBox(i).Y1_30 And Y < mTimeBox(i).Y2_30 Then
            mintCurrentIndex = i
            mintCurrentMinute = 30
            DrawTimeBlocks
        
            RaiseEvent TimeChanged(mdteTime)
        ElseIf X > mTimeBox(i).X1_45 And X < mTimeBox(i).X2_45 And Y > mTimeBox(i).Y1_45 And Y < mTimeBox(i).Y2_45 Then
            mintCurrentIndex = i
            mintCurrentMinute = 45
            DrawTimeBlocks
            
            RaiseEvent TimeChanged(mdteTime)
        End If
    Next
End Sub

Private Sub HighlightMinute(intIndex As Integer, intMinute As Integer)
    Dim lngOrigColor As Long
        
    mdteTime = Format(intIndex & ":" & intMinute, "HH:MM am/pm")
        
    lngOrigColor = UserControl.ForeColor
    
    Select Case intMinute
    Case 0
        UserControl.Line (mTimeBox(intIndex).X1_00, mTimeBox(intIndex).Y1_00)-(mTimeBox(intIndex).X2_00, mTimeBox(intIndex).Y2_00), mlngHighlightColor, BF
        
        If Not mTimeBox(intIndex).i_00 Is Nothing Then
            UserControl.PaintPicture mTimeBox(intIndex).i_00, ICON_INSET, mTimeBox(intIndex).tY_00
        End If
        
        UserControl.ForeColor = mlngHighlightTextColor
        
        If Not mTimeBox(intIndex).t_00 = "" Then
            SetPos TEXT_INSET, mTimeBox(intIndex).tY_00
            UserControl.Print mTimeBox(intIndex).t_00
        End If
        
        SetPos mTimeBox(intIndex).tX_00, mTimeBox(intIndex).tY_00
                
        UserControl.Print "00"
        UserControl.ForeColor = lngOrigColor
        
    Case 15
        UserControl.Line (mTimeBox(intIndex).X1_15, mTimeBox(intIndex).Y1_15)-(mTimeBox(intIndex).X2_15, mTimeBox(intIndex).Y2_15), mlngHighlightColor, BF
        
        If Not mTimeBox(intIndex).i_15 Is Nothing Then
            UserControl.PaintPicture mTimeBox(intIndex).i_15, ICON_INSET, mTimeBox(intIndex).tY_15
        End If
        
        UserControl.ForeColor = mlngHighlightTextColor
        
        If Not mTimeBox(intIndex).t_15 = "" Then
            SetPos TEXT_INSET, mTimeBox(intIndex).tY_15
            UserControl.Print mTimeBox(intIndex).t_15
        End If
        
        SetPos mTimeBox(intIndex).tX_15, mTimeBox(intIndex).tY_15
                
        UserControl.Print "15"
        UserControl.ForeColor = lngOrigColor
        
    Case 30
        UserControl.Line (mTimeBox(intIndex).X1_30, mTimeBox(intIndex).Y1_30)-(mTimeBox(intIndex).X2_30, mTimeBox(intIndex).Y2_30), mlngHighlightColor, BF
        
        If Not mTimeBox(intIndex).i_30 Is Nothing Then
            UserControl.PaintPicture mTimeBox(intIndex).i_30, ICON_INSET, mTimeBox(intIndex).tY_30
        End If
        
        UserControl.ForeColor = mlngHighlightTextColor
        
        If Not mTimeBox(intIndex).t_30 = "" Then
            SetPos TEXT_INSET, mTimeBox(intIndex).tY_30
            UserControl.Print mTimeBox(intIndex).t_30
        End If
        
        SetPos mTimeBox(intIndex).tX_30, mTimeBox(intIndex).tY_30
                
        UserControl.Print "30"
        UserControl.ForeColor = lngOrigColor
        
    Case 45
        UserControl.Line (mTimeBox(intIndex).X1_45, mTimeBox(intIndex).Y1_45)-(mTimeBox(intIndex).X2_45, mTimeBox(intIndex).Y2_45), mlngHighlightColor, BF
           
        If Not mTimeBox(intIndex).i_45 Is Nothing Then
            UserControl.PaintPicture mTimeBox(intIndex).i_45, ICON_INSET, mTimeBox(intIndex).tY_45
        End If
        
        UserControl.ForeColor = mlngHighlightTextColor
        
        If Not mTimeBox(intIndex).t_45 = "" Then
            SetPos TEXT_INSET, mTimeBox(intIndex).tY_45
            UserControl.Print mTimeBox(intIndex).t_45
        End If
        
        SetPos mTimeBox(intIndex).tX_45, mTimeBox(intIndex).tY_45
                
        UserControl.Print "45"
        UserControl.ForeColor = lngOrigColor
    End Select
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    UserControl.BackColor = PropBag.ReadProperty("BackColor", &HFFFFFF)
    UserControl.ForeColor = PropBag.ReadProperty("ForeColor", &H0)
    pneTop.Caption = PropBag.ReadProperty("Caption", Extender.Name)
    mblnIntegralHeight = PropBag.ReadProperty("IntegralHeight", True)
    mintClockType = PropBag.ReadProperty("ClockType", 0)
    mlngMarkedColor = PropBag.ReadProperty("MarkedColor", &H0)
    mlngHourColor = PropBag.ReadProperty("HourColor", &H0)
    mlngMinuteColor = PropBag.ReadProperty("MinuteColor", &H808080)
    mlngHighlightColor = PropBag.ReadProperty("HighlightColor", &HFFC0C0)
    mlngHighlightTextColor = PropBag.ReadProperty("HighlightTextColor", &HFFFFFF)
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    PropBag.WriteProperty "BackColor", UserControl.BackColor, &HFFFFFF
    PropBag.WriteProperty "ForeColor", UserControl.ForeColor, &H0
    PropBag.WriteProperty "Caption", pneTop.Caption, Extender.Name
    PropBag.WriteProperty "IntegralHeight", mblnIntegralHeight, True
    PropBag.WriteProperty "ClockType", mintClockType, 0
    PropBag.WriteProperty "MarkedColor", mlngMarkedColor, &H0
    PropBag.WriteProperty "HourColor", mlngHourColor, &H0
    PropBag.WriteProperty "MinuteColor", mlngMinuteColor, &H808080
    PropBag.WriteProperty "HighlightColor", mlngHighlightColor, &HFFC0C0
    PropBag.WriteProperty "HighlightTextColor", mlngHighlightTextColor, &HFFFFFF

    End Sub

Private Sub UserControl_Resize()
    Dim sglHeight As Single
    Dim sglFactor As Single
        
    If UserControl.Width < MIN_WIDTH Then UserControl.Width = MIN_WIDTH
    If UserControl.Height < MIN_HEIGHT Then UserControl.Height = MIN_HEIGHT
        
    sglHeight = (UserControl.Height - (pneTop.Height + TOP_INSET))
    sglFactor = sglHeight \ BLOCK_SIZE
    
    msglFactor = sglFactor
    
    Debug.Print sglFactor
    
    'Integral Height
    If sglHeight Mod BLOCK_SIZE <> 0 Then
        If mblnIntegralHeight Then
            sglFactor = sglFactor + 1
            UserControl.Height = (sglFactor * BLOCK_SIZE) + pneTop.Height + 60
        End If
    End If

    With scroll
        .Top = pneTop.Height
        .Left = UserControl.ScaleWidth - scroll.Width
        .Height = UserControl.ScaleHeight - pneTop.Height
        .LargeChange = sglFactor
        .Max = 24 - sglFactor
    End With
       
    DrawTimeBlocks
End Sub

Private Sub DrawTimeBlocks()
    Dim inthour As Integer
    Dim Y As Single
    Dim i As Integer
    
    UserControl.Cls
        
    Y = pneTop.Height + 100
    
    'Clear All Bounding Box Data
    For i = 0 To 23
        mTimeBox(i).tX_00 = 0
        mTimeBox(i).tY_00 = 0
        mTimeBox(i).X1_00 = 0
        mTimeBox(i).X2_00 = 0
        mTimeBox(i).Y1_00 = 0
        mTimeBox(i).Y2_00 = 0
        mTimeBox(i).tX_15 = 0
        mTimeBox(i).tY_15 = 0
        mTimeBox(i).X1_15 = 0
        mTimeBox(i).X2_15 = 0
        mTimeBox(i).Y1_15 = 0
        mTimeBox(i).Y2_15 = 0
        mTimeBox(i).tX_30 = 0
        mTimeBox(i).tY_30 = 0
        mTimeBox(i).X1_30 = 0
        mTimeBox(i).X2_30 = 0
        mTimeBox(i).Y1_30 = 0
        mTimeBox(i).Y2_30 = 0
        mTimeBox(i).tX_45 = 0
        mTimeBox(i).tY_45 = 0
        mTimeBox(i).X1_45 = 0
        mTimeBox(i).X2_45 = 0
        mTimeBox(i).Y1_45 = 0
        mTimeBox(i).Y2_45 = 0
    Next
        
    'Show Boxes
    For i = mintTopHour To 23
        DrawTime i, Y
        
        Y = Y + BLOCK_SIZE
    Next
End Sub

Private Sub DrawTime(ByVal inthour As Integer, ByVal Y As Single)
    
    Dim lngNormalColor As Long
    Dim intOriginalHour As Integer
    Dim lngOffset As Long