lijh
/
LBdianziqianming
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
Branches Tags
${ item.name }
Create tag ${ searchTerm }
Create branch ${ searchTerm }
from 'main'
${ noResults }
LBdianziqianming/cadVb/COMMON/TOOLS/VB/UNSUPPRT/CALENDAR/CALENDAR.CTL

1937 lines
72 KiB
Raw Permalink Blame History

VERSION 5.00
Begin VB.UserControl Calendar
ClientHeight = 2745
ClientLeft = 0
ClientTop = 0
ClientWidth = 3480
EditAtDesignTime= -1 'True
KeyPreview = -1 'True
PropertyPages = "Calendar.ctx":0000
ScaleHeight = 183
ScaleMode = 3 'Pixel
ScaleWidth = 232
ToolboxBitmap = "Calendar.ctx":0032
Begin VB.TextBox ctlFocus
Height = 285
Left = -300
TabIndex = 0
Top = 900
Width = 150
End
Begin VB.TextBox txtYear
Height = 285
Left = 2280
MaxLength = 4
TabIndex = 3
ToolTipText = "Year"
Top = 120
Width = 495
End
Begin VB.ComboBox cbxMonth
Height = 315
Left = 480
Style = 2 'Dropdown List
TabIndex = 2
ToolTipText = "Month"
Top = 120
Width = 1695
End
Begin VB.CommandButton btnNext
Height = 255
Left = 3060
MaskColor = &H000000FF&
Picture = "Calendar.ctx":012C
Style = 1 'Graphical
TabIndex = 4
ToolTipText = "Go To Next Month"
Top = 120
UseMaskColor = -1 'True
Width = 255
End
Begin VB.CommandButton btnPrev
Height = 255
Left = 60
MaskColor = &H000000FF&
Picture = "Calendar.ctx":020E
Style = 1 'Graphical
TabIndex = 1
ToolTipText = "Go To Previous Month"
Top = 120
UseMaskColor = -1 'True
Width = 255
End
End
Attribute VB_Name = "Calendar"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Attribute VB_Description = "VB Calendar Control Sample"
'----------------------------------------------------------------------
' Calendar.ctl
'----------------------------------------------------------------------
' Implementation file for the VB Calendar control sample.
' This control displays a month-at-a-time view calendar that the
' developer can use to let users view and adjust date values
'----------------------------------------------------------------------
' Copyright (c) 1996, Microsoft Corporation
' All Rights Reserved
'
' Information Contained Herin is Proprietary and Confidential
'----------------------------------------------------------------------
Option Explicit
'======================================================================
' Public Event Declarations
'======================================================================
Public Event DateChange(ByVal OldDate As Date, ByVal NewDate As Date)
Public Event WillChangeDate(ByVal NewDate As Date, Cancel As Boolean)
Public Event DblClick()
Public Event Click()
'======================================================================
' Public Enumerations
'======================================================================
Public Enum CalendarMonths 'months of the year
calJanuary = 1
calFebruary
calMarch
calApril
calMay
calJune
calJuly
calAugust
calSeptember
calOctober
calNovember
calDecember
End Enum 'CalendarMonths
Public Enum DaysOfTheWeek
calUseSystem = 0
calSunday
calMonday
calTuesday
calWednesday
calThursday
calFriday
calSaturday
End Enum 'DaysOfTheWeek
Public Enum CalendarAreas
calNavigationArea
calDayNameArea
calDateArea
calUnknownArea
End Enum 'CalendarAreas
'Short = "F"
'Medium = "Fri"
'Long = "Friday"
Public Enum DayNameFormats
calShortName = 0
calMediumName
calLongName
End Enum 'DayNameFormats
'======================================================================
' Private Constants
'======================================================================
Private Const NUMCOLS As Long = 7 'number of cols in grid
Private Const NUMROWS As Long = 6 'number of rows in grid
Private Const NUMMONTHS As Long = 12 'number of months in a year
Private Const NUMDAYS As Long = 7 'number of days in a week
Private Const BORDER3D As Long = 2 'num pixels for good 3d border
Private Const FOCUSBORDER As Long = 1 'num pixels for focus border
Private Enum DaySets
PrevMonthDays
CurMonthDays
NextMonthDays
End Enum 'DaySets
Private Enum DayEffectFlags
calEffectOff = 1
calEffectOn = -1
calEffectDefault = 0
End Enum 'DayEffectFlags
'======================================================================
' Private Data Members
'======================================================================
'Current Date
Private mnDay As Long 'current day number
Private mnYear As Long 'current year number
Private mnMonth As Long 'currnet month number
'Formatting and Appearance Settings
Private mnFirstDayOfWeek As VbDayOfWeek 'first day of the week
Private mnDayNameFormat As DayNameFormats
Private mfntDayNames As StdFont 'font to use for painting day names
Private mclrDayNames As OLE_COLOR 'color for the day names
Private mfShowIterrators As Boolean 'determines if iterrator buttons
'should be shown or not
Private mfMonthReadOnly As Boolean 'month selector or none
Private mfYearReadOnly As Boolean 'month selector or none
'Behavior settings
Private mfLocked As Boolean 'read-only or not
'String Arrays For Month and Day Names
Private masMonthNames(NUMMONTHS - 1) As String 'string array of month names
Private masDayNames(NUMDAYS - 1) As String 'string array of day names
'this should be replaced with day styles eventually
Private mfntDayFont As StdFont 'font to use for painting dates in
'the current month
Private mclrDay As OLE_COLOR 'color for the day numbers
Private mafDayBold(1 To 31) As DayEffectFlags 'array of flags for day being bold
Private mafDayItalic(1 To 31) As DayEffectFlags 'array of flags for day being italic
'Current Column Width and Row Height For Calendar Grid
Private mcxColWidth As Long 'width of each column in the grid
Private mcyRowHeight As Long 'height of each row in the grid
'RECTs For Different Calendar Areas
Private mrcNavArea As RECT 'rect bounding the navigation area
Private mrcDayNameArea As RECT 'rect bounding the day name area
Private mrcCalArea As RECT 'area bounding the calendar days
Private mrcFocusArea As RECT 'current focus area
'General Utility Members
Private mobjRes As ResLoader 'resource loading object (localization)
Private mfIgnoreMonthYearChange As Boolean 'HACKY flag for ignoring the programatic
'change of the month and year navigation
'controls.
Private maRepaintDays(1) As Long 'array of day numbers to repaint
Private mfFastRepaint As Boolean 'boolean flag used to do fast repaint
'when only the day selected is changing
'======================================================================
' Public Property Procedures
'======================================================================
'----------------------------------------------------------------------
' Version Get
'----------------------------------------------------------------------
' Purpose: Gets the version number of the control
'----------------------------------------------------------------------
Public Property Get Version() As String
Attribute Version.VB_Description = "Returns the version number of this control."
Attribute Version.VB_ProcData.VB_Invoke_Property = ";Misc"
Version = App.Major & "." & App.Minor & "." & App.Revision
End Property 'Get Version()
'----------------------------------------------------------------------
' Day Get/Let
'----------------------------------------------------------------------
' Purpose: Gets and lets the current day value
'----------------------------------------------------------------------
Public Property Get Day() As Long
Attribute Day.VB_Description = "Returns/Sets the Day number of the selected date."
Attribute Day.VB_ProcData.VB_Invoke_Property = ";Data"
Day = mnDay
End Property 'Get Day()
Public Property Let Day(nNewVal As Long)
'validate our inputs
If nNewVal > 0 And nNewVal <= MaxDayInMonth(mnMonth, mnYear) Then
ChangeValue nNewVal, mnMonth, mnYear
Else
mobjRes.RaiseUserError errPropValueRange, Array("Day", "0", CStr(MaxDayInMonth(mnMonth, mnYear)))
End If
End Property 'Let Day()
'----------------------------------------------------------------------
' Month Get/Let
'----------------------------------------------------------------------
' Purpose: Gets and lets the current month value
'----------------------------------------------------------------------
Public Property Get Month() As CalendarMonths
Attribute Month.VB_Description = "Returns/Sets the month number of the currently selected date."
Attribute Month.VB_ProcData.VB_Invoke_Property = ";Data"
Month = mnMonth
End Property 'Get Month()
Public Property Let Month(nNewVal As CalendarMonths)
'validate our inputs
'note we still need to do this even though we're using
'an enumeration since VB only treats this as a long value
If nNewVal > 0 And nNewVal <= 12 Then
ChangeValue mnDay, nNewVal, mnYear
Else
mobjRes.RaiseUserError errPropValueRange, Array("Month", "0", "12")
End If
End Property 'Let Month()
'----------------------------------------------------------------------
' Year Get/Let
'----------------------------------------------------------------------
' Purpose: Gets and lets the current year value
'----------------------------------------------------------------------
Public Property Get Year() As Long
Attribute Year.VB_Description = "Returns/Sets the year number of the currently selected date."
Attribute Year.VB_ProcData.VB_Invoke_Property = ";Data"
Year = mnYear
End Property 'Get Year()
Public Property Let Year(nNewVal As Long)
'validate our inputs
'year must be between 100 and 9999 due to the restrictions
'of the date data type in basic
If nNewVal >= 100 And nNewVal <= 9999 Then
ChangeValue mnDay, mnMonth, nNewVal
Else
mobjRes.RaiseUserError errPropValueRange, Array("Year", "100", "9999")
End If
End Property 'Let Year()
'----------------------------------------------------------------------
' Value Get/Let
'----------------------------------------------------------------------
' Purpose: Gets and lets the current date value
'----------------------------------------------------------------------
Public Property Get Value() As Date
Attribute Value.VB_Description = "Returns/Sets the currently selected date in the control."
Attribute Value.VB_ProcData.VB_Invoke_Property = ";Data"
Attribute Value.VB_MemberFlags = "3c"
Value = DateSerial(mnYear, mnMonth, mnDay)
End Property 'Get Value()
Public Property Let Value(dtNew As Date)
ChangeValue VBA.Day(dtNew), VBA.Month(dtNew), VBA.Year(dtNew)
End Property 'Let Value()
'----------------------------------------------------------------------
' DayFont Get/Set
'----------------------------------------------------------------------
' Purpose: Gets or sets the font to use for date numbers
'----------------------------------------------------------------------
Public Property Get DayFont() As Font
Attribute DayFont.VB_Description = "Returns/Sets the font used for the day numbers."
Attribute DayFont.VB_ProcData.VB_Invoke_Property = ";Appearance"
Attribute DayFont.VB_UserMemId = -512
Set DayFont = mfntDayFont
End Property 'Get DayFont()
'*** VB BUG Workaround ***
'The fntNew argument is passed in ByVal in order to
'get this property to show in the built-in Font
'property page. When the bug is fixed, change this
'back to ByRef (remove ByVal)
Public Property Set DayFont(ByVal fntNew As Font)
Set mfntDayFont = fntNew
UserControl.Refresh
End Property 'Set DayFont()
'----------------------------------------------------------------------
' DayNameFont Get/Set
'----------------------------------------------------------------------
' Purpose: Gets or sets the font to use for day names
'----------------------------------------------------------------------
Public Property Get DayNameFont() As Font
Attribute DayNameFont.VB_Description = "Returns/Sets the font used for the day names."
Attribute DayNameFont.VB_ProcData.VB_Invoke_Property = ";Appearance"
Set DayNameFont = mfntDayNames
End Property 'Get DayFont()
'*** VB BUG Workaround ***
'The fntNew argument is passed in ByVal in order to
'get this property to show in the built-in Font
'property page. When the bug is fixed, change this
'back to ByRef (remove ByVal)
Public Property Set DayNameFont(ByVal fntNew As Font)
Set mfntDayNames = fntNew
UserControl.Refresh
End Property 'Set DayFont()
'----------------------------------------------------------------------
' DayBold() Get/Let
'----------------------------------------------------------------------
' Purpose: This property allows the user to set a particular day to bold
' or not so as to give the effect of a 'special' day
' Inputs: day number (1 to max day in current month)
' Outputs: True if it's Bold, False if not
'----------------------------------------------------------------------
Public Property Get DayBold(DayNumber As Long) As Boolean
Attribute DayBold.VB_Description = "Returns/Sets the Bold state for a day in the current month."
'if the setting for this day is "default" then the
'value returned depends on the bold state of the
'DayFont property
If mafDayBold(DayNumber) = calEffectDefault Then
DayBold = mfntDayFont.Bold
Else
DayBold = (mafDayBold(DayNumber) = calEffectOn)
End If
End Property 'Get DayBold()
Public Property Let DayBold(DayNumber As Long, NewVal As Boolean)
If NewVal = True Then
mafDayBold(DayNumber) = calEffectOn
Else
mafDayBold(DayNumber) = calEffectOff
End If
End Property 'Let DayBold()
'----------------------------------------------------------------------
' DayItalic() Get/Let
'----------------------------------------------------------------------
' Purpose: This property allows the user to set a particular day italic
' or not so as to give the effect of a 'special' day
' Inputs: day number (1 to max day in current month)
' Outputs: True if it's Italic, False if not
'----------------------------------------------------------------------
Public Property Get DayItalic(DayNumber As Long) As Boolean
Attribute DayItalic.VB_Description = "Returns/Sets the Italic state for a day in the current month."
'if the setting for this day is "default" then the
'value returned depends on the italic state of the
'DayFont property
If mafDayItalic(DayNumber) = calEffectDefault Then
DayItalic = mfntDayFont.Italic
Else
DayItalic = (mafDayItalic(DayNumber) = calEffectOn)
End If
End Property 'Get DayItalic()
'**Let
Public Property Let DayItalic(DayNumber As Long, NewVal As Boolean)
If NewVal = True Then
mafDayItalic(DayNumber) = calEffectOn
Else
mafDayItalic(DayNumber) = calEffectOff
End If
End Property 'Let DayItalic()
'----------------------------------------------------------------------
' StartOfWeek Get/Let
'----------------------------------------------------------------------
' Purpose: Gets or lets the first day to display in a week
'----------------------------------------------------------------------
Public Property Get StartOfWeek() As DaysOfTheWeek
Attribute StartOfWeek.VB_Description = "Returns/Sets the first day of the week which will be displayed in the left-most column."
Attribute StartOfWeek.VB_ProcData.VB_Invoke_Property = ";Appearance"
StartOfWeek = mnFirstDayOfWeek
End Property 'Get StartOfWeek()
Public Property Let StartOfWeek(nNewVal As DaysOfTheWeek)
'validate our inputs
If nNewVal >= calUseSystem And nNewVal <= calSaturday Then
mnFirstDayOfWeek = nNewVal
'do a Refresh to make the control repaint
UserControl.Refresh
Else
mobjRes.RaiseUserError errPropValueRange, Array("StartOfWeek", calUseSystem, calSaturday)
End If 'valid inputs
End Property 'Let StartOfWeek()
'----------------------------------------------------------------------
' DayNameFormat Get/Let
'----------------------------------------------------------------------
' Purpose: Gets or lets the format to use for day names
' (short, medium, long)
'----------------------------------------------------------------------
Public Property Get DayNameFormat() As DayNameFormats
Attribute DayNameFormat.VB_Description = "Returns/Sets the format to use for the day names (Short = ""M"", Medium = ""Mon"", Long = ""Monday"")."
Attribute DayNameFormat.VB_ProcData.VB_Invoke_Property = ";Appearance"
DayNameFormat = mnDayNameFormat
End Property 'Get DayNameFormat
Public Property Let DayNameFormat(nNewFormat As DayNameFormats)
'validate the input
If nNewFormat >= calShortName And nNewFormat <= calLongName Then
'set the new format and re-load the day names
mnDayNameFormat = nNewFormat
LoadDayNames
UserControl.Refresh
Else
mobjRes.RaiseUserError errPropValueRange, Array("DayNameFormat", calShortName, calLongName)
End If 'valid inputs
End Property 'Let DayNameFormat
'----------------------------------------------------------------------
' ShowIterratorButtons Get/Let
'----------------------------------------------------------------------
' Purpose: Gets or lets the option for showing or hiding the month
' iterrator buttons
'----------------------------------------------------------------------
Public Property Get ShowIterrationButtons() As Boolean
Attribute ShowIterrationButtons.VB_Description = "Returns/Sets the visible state of the previous and next month navigation buttons."
Attribute ShowIterrationButtons.VB_ProcData.VB_Invoke_Property = ";Appearance"
ShowIterrationButtons = mfShowIterrators
End Property 'Get ShowIterrationButtons()
Public Property Let ShowIterrationButtons(fNew As Boolean)
'if it's not changing, don't bother
If fNew = mfShowIterrators Then Exit Property
'assign the new value
mfShowIterrators = fNew
'and adjust the visible state of the buttons
btnPrev.Visible = mfShowIterrators
btnNext.Visible = mfShowIterrators
'trigger the resize event to recalc the widths
'of the other navigation controls
UserControl_Resize
End Property 'Let ShowIterrationButtons()
'----------------------------------------------------------------------
' MonthReadOnly Get/Let
'----------------------------------------------------------------------
' Purpose: Gets and lets the option of making the month selector
' read-only or not
'----------------------------------------------------------------------
Public Property Get MonthReadOnly() As Boolean
Attribute MonthReadOnly.VB_Description = "Returns/Sets the read-only state of the month navigation combo box."
Attribute MonthReadOnly.VB_ProcData.VB_Invoke_Property = ";Appearance"
MonthReadOnly = mfMonthReadOnly
End Property 'Get MonthReadOnly()
Public Property Let MonthReadOnly(fNew As Boolean)
'if it's not changing, don't bother
If fNew = mfMonthReadOnly Then Exit Property
'set the new value and hide or show the month selector
mfMonthReadOnly = fNew
cbxMonth.Visible = Not mfMonthReadOnly
End Property 'Let MonthReadOnly()
'----------------------------------------------------------------------
' YearReadOnly Get/Let
'----------------------------------------------------------------------
' Purpose: Gets and lets the option of making the year selector
' read-only or not
'----------------------------------------------------------------------
Public Property Get YearReadOnly() As Boolean
Attribute YearReadOnly.VB_Description = "Returns/Sets the read-only state of the year navigation text box."
Attribute YearReadOnly.VB_ProcData.VB_Invoke_Property = ";Appearance"
YearReadOnly = mfYearReadOnly
End Property 'Get YearReadOnly()
Public Property Let YearReadOnly(fNew As Boolean)
'if it's not changing, don't bother
If fNew = mfYearReadOnly Then Exit Property
'set the new value and hide or show the month selector
mfYearReadOnly = fNew
txtYear.Visible = Not mfYearReadOnly
End Property 'Let YearReadOnly()
'----------------------------------------------------------------------
' Locked Get/Let
'----------------------------------------------------------------------
' Purpose: Gets and sets the Locked option which makes the whole thing
' read-only or not
'----------------------------------------------------------------------
Public Property Get Locked() As Boolean
Attribute Locked.VB_Description = "Returns/Sets the locked state of the control. When locked, the user cannot change the selected date."
Attribute Locked.VB_ProcData.VB_Invoke_Property = ";Behavior"
Locked = mfLocked
End Property 'Get Locked()
Public Property Let Locked(fNew As Boolean)
'set the private variable
mfLocked = fNew
'set the locked state of contained controls
'we'll disable the buttons if locked since
'there is no locked state for buttons
cbxMonth.Locked = fNew
txtYear.Locked = fNew
btnNext.Enabled = Not fNew
btnPrev.Enabled = Not fNew
End Property 'Let Locked()
'----------------------------------------------------------------------
' DayColor Get/Let
'----------------------------------------------------------------------
' Purpose: Gets and sets the color used for the day numbers
'----------------------------------------------------------------------
Public Property Get DayColor() As OLE_COLOR
Attribute DayColor.VB_Description = "Returns/Sets the color used for the day numbers."
Attribute DayColor.VB_ProcData.VB_Invoke_Property = ";Appearance"
Attribute DayColor.VB_UserMemId = -513
DayColor = mclrDay
End Property 'Get DayColor()
Public Property Let DayColor(NewVal As OLE_COLOR)
mclrDay = NewVal
UserControl.Refresh
End Property 'Let DayColor()
'----------------------------------------------------------------------
' DayNameColor Get/Let
'----------------------------------------------------------------------
' Purpose: Gets and sets the color used for the day numbers
'----------------------------------------------------------------------
Public Property Get DayNameColor() As OLE_COLOR
Attribute DayNameColor.VB_Description = "Returns/Sets the color used for the day names (i.e. days of the week)."
Attribute DayNameColor.VB_ProcData.VB_Invoke_Property = ";Appearance"
DayColor = mclrDayNames
End Property 'Get DayNameColor()
Public Property Let DayNameColor(NewVal As OLE_COLOR)
mclrDayNames = NewVal
UserControl.Refresh
End Property 'Let DayNameColor()
'======================================================================
' Public Methods
'======================================================================
'----------------------------------------------------------------------
' HitTest()
'----------------------------------------------------------------------
' Purpose: Does a hit test based on x,y coordinates
' Inputs: x and y coordinates
' Outputs: Area of the control and specific date if over one
'----------------------------------------------------------------------
Public Sub HitTest(ByVal X As Long, ByVal Y As Long, Area As Long, HitDate As Date)
Attribute HitTest.VB_Description = "Returns the area and day number (if any) that corresponds to a given X,Y position."
Dim nRow As Long
Dim nCol As Long
'assert that the x and y are indeed in our coordinate system
Debug.Assert (X <= UserControl.ScaleWidth)
Debug.Assert (Y <= UserControl.ScaleHeight)
'determine the area of the control that x and y are over
If X > mrcNavArea.Right Then
Area = calUnknownArea
Else
If Y >= mrcNavArea.Top And Y <= mrcNavArea.Bottom Then
Area = calNavigationArea
ElseIf Y >= mrcDayNameArea.Top And Y <= mrcDayNameArea.Bottom Then
Area = calDayNameArea
ElseIf Y >= mrcCalArea.Top And Y <= mrcCalArea.Bottom Then
Area = calDateArea
Else
Area = calUnknownArea
End If 'determine area by y
End If 'x is past right of all areas
'if we are in the date area, calculate the hit date
If Area = calDateArea Then
'determine the row and column and make them 0-based
nRow = ((Y - mrcCalArea.Top) \ mcyRowHeight) - 1
If (Y - mrcCalArea.Top) Mod mcyRowHeight > 0 Then
nRow = nRow + 1
End If
nCol = ((X - mrcCalArea.Left) \ mcxColWidth) - 1
If (X - mrcCalArea.Left) Mod mcxColWidth > 0 Then
nCol = nCol + 1
End If
'given the row and column, determine the date
HitDate = DateForRowCol(nRow, nCol)
End If 'in date area
End Sub 'HitTest
'----------------------------------------------------------------------
' Refresh()
'----------------------------------------------------------------------
' Purpose: Refreshes/repaints the entire control
' Inputs: none
' Outputs: none
'----------------------------------------------------------------------
Public Sub Refresh()
Attribute Refresh.VB_Description = "Refreshes the control by causing a complete repaint."
'just pass it on...
UserControl.Refresh
End Sub 'Refresh()
'----------------------------------------------------------------------
' About()
'----------------------------------------------------------------------
' Purpose: Opens the About box for the control--this is marked hidden
' so that it doesn't show up in the statement completion
' but we do mark this with the DispID of AboutBox so that it
' shows in the property sheet with an elipsis button
' Inputs: none
' Outputs: none
'----------------------------------------------------------------------
Public Sub About()
Attribute About.VB_Description = "Shows the about box for the control."
Attribute About.VB_UserMemId = -552
Attribute About.VB_MemberFlags = "40"
frmAbout.Show vbModal
End Sub 'About()
'======================================================================
' Initialize and Terminate Events
'======================================================================
Private Sub UserControl_Initialize()
On Error GoTo Err_Init
'set the resource loader
'daveste -- 7/31/96
'TODO: put in code to load a satellite resource DLL based on the
'locale ID of the ambient host
Set mobjRes = New ResLoader
'load the month names into the combo box
LoadMonthNames
'initialize the area rects that don't depend on the
'size of the control (which are left and top and sometimes bottom)
'doing this here lets us reduce the code needed to execute
'when the control is resized which will happen more often
'than the control being initialized.
mrcNavArea.Left = 1
mrcNavArea.Top = 1
'height of navigation area is the height of the month combo
'plus 4, since we will draw a 3d box around the controls
mrcNavArea.Bottom = cbxMonth.Height + (2 * BORDER3D)
mrcDayNameArea.Left = 1
mrcDayNameArea.Top = mrcNavArea.Bottom
'height of the day name area should be the height of
'the day name font plus 6 pixels for 3d effects
mrcDayNameArea.Bottom = mrcDayNameArea.Top + UserControl.TextHeight("A") + 6
mrcCalArea.Left = 1
mrcCalArea.Top = mrcDayNameArea.Bottom
'set the position and sizes of the navigation controls that
'don't depend on the size of the control (like left and top
'values).
btnPrev.Move mrcNavArea.Left, mrcNavArea.Top, btnPrev.Width, mrcNavArea.Bottom - mrcNavArea.Top
btnNext.Top = mrcNavArea.Top
btnNext.Height = mrcNavArea.Bottom - mrcNavArea.Top
cbxMonth.Move mrcNavArea.Left + btnPrev.Width + BORDER3D, mrcNavArea.Top + BORDER3D
txtYear.Height = cbxMonth.Height
txtYear.Top = mrcNavArea.Top + BORDER3D
'set the disabled picture for the prev and next buttons
'to be the same as the regular picture--this will let us
'give a locked effect by disabling the prev and next buttons
btnPrev.DisabledPicture = btnPrev.Picture
btnNext.DisabledPicture = btnNext.Picture
Exit Sub
Err_Init:
Debug.Assert False
Exit Sub
End Sub 'UserControl_Initialize()
'======================================================================
' Private Event Handles
'======================================================================
'----------------------------------------------------------------------
' InitProperties Event
'----------------------------------------------------------------------
' Purpose: Called when the control is first put on a form
' One-time initialization of data members
' Inputs: None
' Outputs: None
'----------------------------------------------------------------------
Private Sub UserControl_InitProperties()
Dim dt As Date
On Error GoTo Err_InitProps
'initialize the day, month and year to the current system date
dt = Date
mnDay = VBA.Day(dt)
mnMonth = VBA.Month(dt)
mnYear = VBA.Year(dt)
mfIgnoreMonthYearChange = True
cbxMonth.ListIndex = mnMonth - 1
txtYear.Text = mnYear
mfIgnoreMonthYearChange = False
'create new font objects for the day and day name
'fonts and copy the font attributes from the
'user control's ambient font into them
Set mfntDayFont = New StdFont
CopyFont UserControl.Ambient.Font, mfntDayFont
Set mfntDayNames = New StdFont
CopyFont UserControl.Ambient.Font, mfntDayNames
mfntDayNames.Bold = True
'initialize the day and dayname colors to the ambient's
'fore color value
mclrDay = vbBlack
mclrDayNames = vbBlack
'initialize the day name format to medium
mnDayNameFormat = calMediumName
LoadDayNames
'init various appearance options
mfShowIterrators = True
mfMonthReadOnly = False
mfYearReadOnly = False
mfLocked = False
Exit Sub
Err_InitProps:
Debug.Assert False
Exit Sub
End Sub 'UserControl_InitProperties()
'----------------------------------------------------------------------
' ReadProperties Event
'----------------------------------------------------------------------
' Purpose: Called when we need to read property settings back in
' Inputs: the property bag class for reading
' Outputs: None
'----------------------------------------------------------------------
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
Dim dtCurrent As Date
dtCurrent = Date
On Error Resume Next
'read in the properties from the property bag
mnFirstDayOfWeek = PropBag.ReadProperty("StartOfWeek", vbUseSystemDayOfWeek)
ChangeValue PropBag.ReadProperty("Day", VBA.Day(dtCurrent)), _
PropBag.ReadProperty("Month", VBA.Month(dtCurrent)), _
PropBag.ReadProperty("Year", VBA.Year(dtCurrent))
Set mfntDayNames = PropBag.ReadProperty("DayNameFont", UserControl.Font)
Set mfntDayFont = PropBag.ReadProperty("DayFont", UserControl.Font)
mclrDay = PropBag.ReadProperty("DayColor", vbBlack)
mclrDayNames = PropBag.ReadProperty("DayNameColor", vbBlack)
mnDayNameFormat = PropBag.ReadProperty("DayNameFormat", calMediumName)
LoadDayNames
Me.ShowIterrationButtons = PropBag.ReadProperty("ShowIterrationButtons", True)
Me.MonthReadOnly = PropBag.ReadProperty("MonthReadOnly", False)
Me.YearReadOnly = PropBag.ReadProperty("YearReadOnly", False)
Me.Locked = PropBag.ReadProperty("Locked", False)
'trigger a resize since this event happens after the initial
'resize when going to run mode
UserControl_Resize
End Sub 'UserControl_ReadProperties()
'----------------------------------------------------------------------
' WriteProperties Event
'----------------------------------------------------------------------
' Purpose: Called when we need to write property settings out to disk
' Inputs: the property bag class for writing
' Outputs: None
'----------------------------------------------------------------------
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
On Error Resume Next
'write the current property values to the property bag
PropBag.WriteProperty "Day", mnDay
PropBag.WriteProperty "Month", mnMonth
PropBag.WriteProperty "Year", mnYear
PropBag.WriteProperty "StartOfWeek", mnFirstDayOfWeek, vbUseSystemDayOfWeek
PropBag.WriteProperty "DayNameFont", mfntDayNames, UserControl.Font
PropBag.WriteProperty "DayFont", mfntDayFont, UserControl.Font
PropBag.WriteProperty "DayNameFormat", mnDayNameFormat, calMediumName
PropBag.WriteProperty "DayColor", mclrDay, vbBlack
PropBag.WriteProperty "DayNameColor", mclrDayNames, vbBlack
PropBag.WriteProperty "ShowIterrationButtons", mfShowIterrators, True
PropBag.WriteProperty "MonthReadOnly", mfMonthReadOnly, False
PropBag.WriteProperty "YearReadOnly", mfYearReadOnly, False
PropBag.WriteProperty "Locked", mfLocked, False
End Sub 'UserControl_WriteProperties()
'----------------------------------------------------------------------
' Paint Event
'----------------------------------------------------------------------
' Purpose: Called when the control needs to be repainted
' Inputs: None
' Outputs: None
'----------------------------------------------------------------------
Private Sub UserControl_Paint()
Dim dcWork As OffScreenDC
Dim nTop As Long
Dim nLeft As Long
Dim nWidth As Long
Dim nHeight As Long
Dim nDay As Long
Dim nRow As Long
Dim nCol As Long
Dim nLastDay As Long
Dim eDaySet As DaySets
Dim rgbColor As Long
Dim fDefBold As Boolean
Dim fDefItalic As Boolean
On Error GoTo Err_Paint
'save the initial bold and italic state of our day font
fDefBold = mfntDayFont.Bold
fDefItalic = mfntDayFont.Italic
Set dcWork = New OffScreenDC
dcWork.Initialize UserControl.hdc, UserControl.ScaleWidth, UserControl.ScaleHeight
'set the text color to be the color chosen for
'the days of the week names
OleTranslateColor mclrDayNames, 0, rgbColor
dcWork.TextColor = rgbColor
If mfFastRepaint Then
FastRepaint dcWork
Exit Sub
End If
'fill the background of the control with the ambient's
'background color
nLeft = 0
nTop = 0
nWidth = UserControl.ScaleWidth
nHeight = UserControl.ScaleHeight
'I use the OLE API OleTranslateColor here to translate
'an OLE color to an RGB value. VB will return an OLE color
'value for the ambient's back color and this API will convert
'it to an RGB value for painting.
OleTranslateColor UserControl.Ambient.BackColor, 0, rgbColor
dcWork.FillRect nLeft, nTop, nWidth, nHeight, rgbColor
'next fill a black rect that will serve as a thin back outline
'around the painted part of the control
nWidth = mrcNavArea.Right + 1
nHeight = mrcDayNameArea.Bottom + (mcyRowHeight * NUMROWS) + 1
dcWork.FillRect 0, 0, nWidth, nHeight, vbBlack
'draw a 3d rect around the navigation controls
nTop = mrcNavArea.Top
nHeight = mrcNavArea.Bottom - mrcNavArea.Top
If mfShowIterrators Then
nLeft = mrcNavArea.Left + btnPrev.Width
nWidth = btnNext.Left - nLeft
Else
nLeft = mrcNavArea.Left
nWidth = mrcNavArea.Right - mrcNavArea.Left
End If 'mfShowIterrators
dcWork.Draw3DRect nLeft, nTop, nWidth, nHeight
'if the month is read only, draw the month name
If mfMonthReadOnly Then
Set dcWork.Font = cbxMonth.Font
'squeeze the width in by one to make a better 3d effect
dcWork.Draw3DRect cbxMonth.Left, cbxMonth.Top, _
cbxMonth.Width - 1, cbxMonth.Height, _
cbxMonth.List(cbxMonth.ListIndex), _
caCenterCenter, Sunken
End If 'month is read only
'if the year is read only, draw the year number
If mfYearReadOnly Then
Set dcWork.Font = txtYear.Font
dcWork.Draw3DRect txtYear.Left, txtYear.Top, _
txtYear.Width, txtYear.Height, _
txtYear.Text, caCenterCenter, Sunken
End If 'year is read only
'paint the day names
PaintDayNames dcWork
'change the text color to dark gray to paint the previous month days
'daveste -- 7/31/96
'TODO: this should be replaced with day styles or at least with
'a property the control the font and color of these other dates
dcWork.TextColor = RGB(128, 128, 128)
'get the first and last days of the previous month to paint
GetPrevMonthDays mnMonth, mnYear, nDay, nLastDay
eDaySet = PrevMonthDays
Set dcWork.Font = mfntDayFont
'draw a grid of date numbers for the current month
For nRow = 0 To NUMROWS - 1
For nCol = 0 To NUMCOLS - 1
'if we've done painting the current set of days
'switch to the next set
If nDay > nLastDay Then
If eDaySet = PrevMonthDays Then
OleTranslateColor mclrDay, 0, rgbColor
dcWork.TextColor = rgbColor
nDay = 1
nLastDay = MaxDayInMonth(mnMonth, mnYear)
eDaySet = CurMonthDays
Else
dcWork.TextColor = RGB(128, 128, 128)
nDay = 1
nLastDay = 100 'no need to calc the last
'day since the for loops
'will govern when to stop
eDaySet = NextMonthDays
End If 'day set was previous month
End If 'done painting this day set
'paint the day
'set the font attributes for the day being painted
If eDaySet = CurMonthDays Then
If mafDayBold(nDay) = calEffectDefault Then
'optimize for the case where no days are bold
If mfntDayFont.Bold <> fDefBold Then
mfntDayFont.Bold = fDefBold
Set dcWork.Font = mfntDayFont
End If
Else
mfntDayFont.Bold = (mafDayBold(nDay) = calEffectOn)
Set dcWork.Font = mfntDayFont
End If 'DayBold setting is default
If mafDayItalic(nDay) = calEffectDefault Then
'optimize for the case where no days are italic
If mfntDayFont.Italic <> fDefItalic Then
mfntDayFont.Italic = fDefItalic
Set dcWork.Font = mfntDayFont
End If
Else
mfntDayFont.Italic = (mafDayItalic(nDay) = calEffectOn)
Set dcWork.Font = mfntDayFont
End If
End If 'we're in the current month day set
'if it's the current day, draw it selected
If nDay = mnDay And eDaySet = CurMonthDays Then
dcWork.Draw3DRect mrcCalArea.Left + (nCol * mcxColWidth), _
mrcCalArea.Top + (nRow * mcyRowHeight), _
mcxColWidth, mcyRowHeight, CStr(nDay), _
caCenterCenter, Selected
Else
dcWork.Draw3DRect mrcCalArea.Left + (nCol * mcxColWidth), _
mrcCalArea.Top + (nRow * mcyRowHeight), _
mcxColWidth, mcyRowHeight, CStr(nDay)
End If 'current day
'increment the day number
nDay = nDay + 1
Next nCol
Next nRow
'blast the control to the screen
dcWork.BlastToScreen
'if the dummy control has focus, and we are in run-mode,
'draw a focus rect around the current focus area
If UserControl.ActiveControl Is ctlFocus Then
DrawFocusRect UserControl.hdc, mrcFocusArea
End If
'restore the initial settings for bold and italic
'in our day font
mfntDayFont.Bold = fDefBold
mfntDayFont.Italic = fDefItalic
Exit Sub
Err_Paint:
Debug.Assert False
Exit Sub
End Sub 'UserControl_Paint()
'----------------------------------------------------------------------
' Resize Event
'----------------------------------------------------------------------
' Purpose: Called when the control is resized by the developer
' Inputs: None
' Outputs: None
'----------------------------------------------------------------------
Private Sub UserControl_Resize()
Dim nNewWidth As Long 'new scale width
Dim nNewHeight As Long 'new scale height
Dim nUsableWidth As Long 'actual width we can use
On Error GoTo Err_Resize
nNewWidth = UserControl.ScaleWidth
nNewHeight = UserControl.ScaleHeight
'since all the grid cells need to be the same width
'the usable width is the width we will consume and there
'maybe unused pixels due to left-overs from division
nUsableWidth = ((nNewWidth - (2 * mrcCalArea.Left)) \ NUMCOLS) * NUMCOLS
'recalculate the bounding rectangles for the various areas
'of the control (navigation, day names, and calendar days)
mrcNavArea.Right = mrcNavArea.Left + nUsableWidth
mrcDayNameArea.Right = mrcDayNameArea.Left + nUsableWidth
mrcCalArea.Right = mrcCalArea.Left + nUsableWidth
mrcCalArea.Bottom = nNewHeight
'Recalculate the width and heights of the grid rows and columns
mcxColWidth = (nNewWidth - (2 * mrcCalArea.Left)) \ NUMCOLS
mcyRowHeight = (mrcCalArea.Bottom - mrcCalArea.Top) \ NUMROWS
'resize the month and year selection controls
btnNext.Left = mrcNavArea.Right - btnNext.Width
'if there's not enough room, just display the buttons
If (mrcNavArea.Right - mrcNavArea.Left) <= _
(btnNext.Width + btnPrev.Width + txtYear.Width + 10) _
And mfShowIterrators Then
cbxMonth.Visible = False
txtYear.Visible = False
Else
If Not mfMonthReadOnly Then cbxMonth.Visible = True
If Not mfYearReadOnly Then txtYear.Visible = True
If mfShowIterrators Then
cbxMonth.Left = mrcNavArea.Left + btnPrev.Width + BORDER3D
txtYear.Left = btnNext.Left - txtYear.Width - BORDER3D
Else
cbxMonth.Left = mrcNavArea.Left + BORDER3D
txtYear.Left = mrcNavArea.Right - txtYear.Width - BORDER3D
End If
cbxMonth.Width = txtYear.Left - cbxMonth.Left
End If 'not enough horizontal room
Exit Sub
Err_Resize:
Debug.Assert False
Exit Sub
End Sub 'UserControl_Resize()
'----------------------------------------------------------------------
' MouseDown Event
'----------------------------------------------------------------------
' Purpose: Called when the mouse button is pushed down while over
' the control's area
' Inputs: Which mouse button, shift state and x and y position
' Outputs: None
'----------------------------------------------------------------------
Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim Area As CalendarAreas
Dim dtOld As Date
Dim dtNew As Date
On Error GoTo Err_MouseDown
'keep the old date to see if it's changed
dtOld = Me.Value
'Do a hit test to determine where the user clicked
Me.HitTest X, Y, Area, dtNew
'if the area was in the date area and the control is not locked,
'switch to the hit date
If (Area = calDateArea) And (Not mfLocked) Then
If dtNew <> dtOld Then
ChangeValue VBA.Day(dtNew), VBA.Month(dtNew), VBA.Year(dtNew)
End If 'date did change
End If 'clicked in date area
'grab focus back if needed
If Not (UserControl.ActiveControl Is ctlFocus) Then
ctlFocus.SetFocus
End If
Exit Sub
Err_MouseDown:
Debug.Assert False
Exit Sub
End Sub 'UserControl_MouseDown()
'----------------------------------------------------------------------
' DblClick Event
'----------------------------------------------------------------------
' Purpose: Called when the user double-clicks on the main control area
' Inputs: None
' Outputs: None
'----------------------------------------------------------------------
Private Sub UserControl_DblClick()
On Error GoTo Err_DblClick
'pass this event to the host
RaiseEvent DblClick
Exit Sub
Err_DblClick:
Exit Sub
End Sub 'UserControl_DblClick()
'----------------------------------------------------------------------
' Click Event
'----------------------------------------------------------------------
' Purpose: Called when the user clicks on the main control area
' Inputs: None
' Outputs: None
'----------------------------------------------------------------------
Private Sub UserControl_Click()
On Error GoTo Err_Click
'raise our click event to the user
RaiseEvent Click
Exit Sub
Err_Click:
Exit Sub
End Sub 'UserControl_Click()
'----------------------------------------------------------------------
' ctlFocus_GotFocus Event
'----------------------------------------------------------------------
' Purpose: Called when the main calendar area is to get focus.
' We use a dummy control to capture focus since we are
' just painting the calendar days and cannot set focus
' to the entire user control.
' Inputs: None
' Outputs: None
'----------------------------------------------------------------------
Private Sub ctlFocus_GotFocus()
'draw a focus rect to signify that the calendar
'area now has focus
DrawFocusRect UserControl.hdc, mrcFocusArea
End Sub 'ctlFocus_GotFocus()
'----------------------------------------------------------------------
' ctlFocus_LostFocus Event
'----------------------------------------------------------------------
' Purpose: Called when the main calendar area has lost focus.
' We use a dummy control to capture focus since we are
' just painting the calendar days and cannot set focus
' to the entire user control.
' Inputs: None
' Outputs: None
'----------------------------------------------------------------------
Private Sub ctlFocus_LostFocus()
'draw a focus rect where the last focus area was
'drawing a focus rect twice removes it
DrawFocusRect UserControl.hdc, mrcFocusArea
End Sub 'ctlFocus_LostFocus()
'----------------------------------------------------------------------
' ctlFocus_KeyDown Event
'----------------------------------------------------------------------
' Purpose: Called when the user presses a key while the dummy control
' has focus
' Inputs: Which key, shift state
' Outputs: None
'----------------------------------------------------------------------
Private Sub ctlFocus_KeyDown(KeyCode As Integer, Shift As Integer)
Dim dtTemp As Date 'temp date for date arithmetic
Select Case KeyCode
Case vbKeyLeft
dtTemp = DateSerial(mnYear, mnMonth, mnDay)
'if shift is down, move by month
If (Shift And vbShiftMask) > 0 Then
dtTemp = DateAdd("m", -1, dtTemp)
ElseIf (Shift And vbCtrlMask) > 0 Then
'else if control is down, move by year
dtTemp = DateAdd("yyyy", -1, dtTemp)
Else
'go back on day
dtTemp = DateAdd("d", -1, dtTemp)
End If
ChangeValue VBA.Day(dtTemp), VBA.Month(dtTemp), _
VBA.Year(dtTemp)
Case vbKeyRight
dtTemp = DateSerial(mnYear, mnMonth, mnDay)
If (Shift And vbShiftMask) > 0 Then
dtTemp = DateAdd("m", 1, dtTemp)
ElseIf (Shift And vbCtrlMask) > 0 Then
'else if control is down, move by year
dtTemp = DateAdd("yyyy", 1, dtTemp)
Else
'go forward one day
dtTemp = DateAdd("d", 1, dtTemp)
End If
ChangeValue VBA.Day(dtTemp), VBA.Month(dtTemp), _
VBA.Year(dtTemp)
Case vbKeyUp
'go one week back
dtTemp = DateSerial(mnYear, mnMonth, mnDay)
dtTemp = DateAdd("ww", -1, dtTemp)
ChangeValue VBA.Day(dtTemp), VBA.Month(dtTemp), _
VBA.Year(dtTemp)
Case vbKeyDown
'go one week forwad
dtTemp = DateSerial(mnYear, mnMonth, mnDay)
dtTemp = DateAdd("ww", 1, dtTemp)
ChangeValue VBA.Day(dtTemp), VBA.Month(dtTemp), _
VBA.Year(dtTemp)
Case vbKeyHome
'if control is down, go to first day of the year
If (Shift And vbCtrlMask) > 0 Then
ChangeValue 1, 1, mnYear
Else
'go to the first day of the current month
ChangeValue 1, mnMonth, mnYear
End If
Case vbKeyEnd
'if control is down, go to last day of the year
If (Shift And vbCtrlMask) > 0 Then
ChangeValue 31, 12, mnYear
Else
'go to the last day of the current month
ChangeValue MaxDayInMonth(mnMonth, mnYear), _
mnMonth, mnYear
End If
End Select
End Sub 'ctlFocus_KeyDown()
'----------------------------------------------------------------------
' cbxMonth_Click Event
'----------------------------------------------------------------------
' Purpose: Called when the user changes the item selected in the moth
' navigation combo box
' Inputs: none
' Outputs: None
'----------------------------------------------------------------------
Private Sub cbxMonth_Click()
If mfIgnoreMonthYearChange Then Exit Sub
'if we are locked, just reset the list index
'to the current month
If mfLocked Then
mfIgnoreMonthYearChange = True
cbxMonth.ListIndex = mnMonth - 1
mfIgnoreMonthYearChange = False
End If
'change the date
ChangeValue mnDay, cbxMonth.ListIndex + 1, mnYear
RaiseEvent Click
End Sub 'cbxMonth_Click()
'----------------------------------------------------------------------
' txtYear_KeyPress Event
'----------------------------------------------------------------------
' Purpose: Called when the user presses a key in the year
' navigation text box
' Inputs: Key Pressed
' Outputs: None
'----------------------------------------------------------------------
Private Sub txtYear_KeyPress(KeyAscii As Integer)
If mfIgnoreMonthYearChange Then Exit Sub
'if they pressed return, process the date change
If KeyAscii = vbKeyReturn Then
'change the date
ChangeValue mnDay, mnMonth, Val(txtYear)
KeyAscii = 0
End If
End Sub 'txtYear_KeyPress
'----------------------------------------------------------------------
' txtYear_Click Event
'----------------------------------------------------------------------
' Purpose: Called when the user clicks the year
' navigation text box
' Inputs: None
' Outputs: None
'----------------------------------------------------------------------
Private Sub txtYear_Click()
RaiseEvent Click
End Sub 'txtYear_Click()
'----------------------------------------------------------------------
' txtYear_GotFocus Event
'----------------------------------------------------------------------
' Purpose: Called when the user moved into the year text box
' Inputs: None
' Outputs: None
'----------------------------------------------------------------------
Private Sub txtYear_GotFocus()
'select all the text that is there
txtYear.SelStart = 0
txtYear.SelLength = Len(txtYear.Text)
End Sub
'----------------------------------------------------------------------
' txtYear_LostFocus Event
'----------------------------------------------------------------------
' Purpose: Called when the user moved out of the year text box
' Inputs: None
' Outputs: None
'----------------------------------------------------------------------
Private Sub txtYear_LostFocus()
If mnYear <> Val(txtYear.Text) Then
ChangeValue mnDay, mnMonth, Val(txtYear.Text)
End If
End Sub 'txtYear_LostFocus()
'----------------------------------------------------------------------
' btnNext_Click Event
'----------------------------------------------------------------------
' Purpose: Called when the user clicks the next month button
' Inputs: none
' Outputs: None
'----------------------------------------------------------------------
Private Sub btnNext_Click()
Dim dtTemp As Date
dtTemp = DateSerial(mnYear, mnMonth, mnDay)
dtTemp = DateAdd("m", 1, dtTemp)
ChangeValue VBA.Day(dtTemp), VBA.Month(dtTemp), VBA.Year(dtTemp)
ctlFocus.SetFocus
RaiseEvent Click
End Sub 'btnNext_Click()
'----------------------------------------------------------------------
' btnPrev_Click Event
'----------------------------------------------------------------------
' Purpose: Called when the user clicks the previous month button
' Inputs: none
' Outputs: None
'----------------------------------------------------------------------
Private Sub btnPrev_Click()
Dim dtTemp As Date
dtTemp = DateSerial(mnYear, mnMonth, mnDay)
dtTemp = DateAdd("m", -1, dtTemp)
ChangeValue VBA.Day(dtTemp), VBA.Month(dtTemp), VBA.Year(dtTemp)
ctlFocus.SetFocus
RaiseEvent Click
End Sub 'btnPrev_Click()
'======================================================================
' Private Helper Methods
'======================================================================
'----------------------------------------------------------------------
' PaintDayNames()
'----------------------------------------------------------------------
' Purpose: Paints names of the week days above the main date grid
' Inputs: reference to the offscreen dc object
' Outputs: none
'----------------------------------------------------------------------
Private Sub PaintDayNames(dc As OffScreenDC)
Dim rc As RECT
Dim nCol As Long
Dim fntOld As StdFont
Dim idx As Long
'make a copy of the day name area rect
rc.Left = mrcDayNameArea.Left
rc.Top = mrcDayNameArea.Top
rc.Right = mrcDayNameArea.Right
rc.Bottom = mrcDayNameArea.Bottom
'set the current font to use
Set fntOld = dc.Font
Set dc.Font = mfntDayNames
'fill a black rect as a border
dc.FillRect rc.Left, rc.Top, rc.Right - rc.Left, _
rc.Bottom - rc.Top, vbBlack
'now draw 3d rects for each day name
rc.Top = rc.Top + 1
rc.Bottom = rc.Bottom - 1
'initialize idx to be the setting for first day of week
'and if that setting is "use system", determine what the
'system is using
If mnFirstDayOfWeek = vbUseSystemDayOfWeek Then
'8/4/96 is a Sunday, so if the system says the day
'of week is other than 1, we'll figure that out
idx = WeekDay(DateSerial(1996, 8, 4), mnFirstDayOfWeek)
Else
idx = mnFirstDayOfWeek
End If 'first day of week was "use system"
For nCol = 0 To NUMCOLS - 1
dc.Draw3DRect (nCol * mcxColWidth) + rc.Left, rc.Top, mcxColWidth, _
rc.Bottom - rc.Top, masDayNames(idx - 1)
'increment the indexer and if it's past the end
'wrap it back around to zero
idx = idx + 1
If idx > NUMCOLS Then idx = 1
Next nCol
'reset the old font
Set dc.Font = fntOld
End Sub 'PaintDayNames()
'----------------------------------------------------------------------
' FastRepaint()
'----------------------------------------------------------------------
' Purpose: Fast repaint routine for painting when only the day number
' changes and not the month or year.
' Inputs: work off screen DC
' Outputs: none
'----------------------------------------------------------------------
Private Sub FastRepaint(dcWork As OffScreenDC)
Dim nLeft As Long
Dim nTop As Long
Dim rgbColor As Long
Dim ct As Long
Dim eAppearance As Appearances
Dim fDefBold As Boolean
Dim fDefItalic As Boolean
'save the initial states of bold and italic in our day font
fDefBold = mfntDayFont.Bold
fDefItalic = mfntDayFont.Italic
'set the font as the day font and the text
'color as black
Set dcWork.Font = mfntDayFont
OleTranslateColor mclrDay, 0, rgbColor
dcWork.TextColor = rgbColor
For ct = 0 To 1
If mafDayBold(maRepaintDays(ct)) = calEffectDefault Then
'optimize for the case where no days are bold
If mfntDayFont.Bold <> fDefBold Then
mfntDayFont.Bold = fDefBold
Set dcWork.Font = mfntDayFont
End If
Else
mfntDayFont.Bold = (mafDayBold(maRepaintDays(ct)) = calEffectOn)
Set dcWork.Font = mfntDayFont
End If 'DayBold setting is default
If mafDayItalic(maRepaintDays(ct)) = calEffectDefault Then
'optimize for the case where no days are italic
If mfntDayFont.Italic <> fDefItalic Then
mfntDayFont.Italic = fDefItalic
Set dcWork.Font = mfntDayFont
End If
Else
mfntDayFont.Italic = (mafDayItalic(maRepaintDays(ct)) = calEffectOn)
Set dcWork.Font = mfntDayFont
End If
'repaint the old day as normal
nLeft = LeftForDay(maRepaintDays(ct))
nTop = TopForDay(maRepaintDays(ct))
If ct = 0 Then
eAppearance = Raised
Else
eAppearance = Selected
End If
dcWork.Draw3DRect nLeft, nTop, _
mcxColWidth, mcyRowHeight, _
CStr(maRepaintDays(ct)), _
caCenterCenter, eAppearance
'blast just this day to the screen
dcWork.BlastToScreen nLeft, nTop, mcxColWidth, mcyRowHeight
Next ct
' 'repaint the newly selected day as selected
' nLeft = LeftForDay(maRepaintDays(1))
' nTop = TopForDay(maRepaintDays(1))
' dcWork.Draw3DRect nLeft, nTop, _
' mcxColWidth, mcyRowHeight, _
' CStr(maRepaintDays(1)), _
' caCenterCenter, Selected
'
' 'blast just this day to the screen
' dcWork.BlastToScreen nLeft, nTop, mcxColWidth, mcyRowHeight
'draw the focus rect on the selected day if
'the dummy focus control has focus
If UserControl.ActiveControl Is ctlFocus Then
DrawFocusRect UserControl.hdc, mrcFocusArea
End If
'restore the initial states of bold and italic in our day font
mfntDayFont.Bold = fDefBold
mfntDayFont.Italic = fDefItalic
'reset the fast repaint flag to False
mfFastRepaint = False
End Sub 'FastRepaint()
'----------------------------------------------------------------------
' MaxDayInMonth()
'----------------------------------------------------------------------
' Purpose: Returns the max day number for a given month number and year
' Inputs: month number
' Outputs: max day number
'----------------------------------------------------------------------
Private Function MaxDayInMonth(nMonth As Long, Optional nYear As Long = 0) As Long
Select Case nMonth
Case 9, 4, 6, 11 '30 days hath September,
'April, June, and November
MaxDayInMonth = 30
Case 2 'February -- check for leapyear
'The full rule for leap years is that they occur in
'every year divisible by four, except that they don't
'occur in years divisible by 100, except that they
'*do* in years divisible by 400.
If (nYear Mod 4) = 0 Then
If nYear Mod 100 = 0 Then
If nYear Mod 400 = 0 Then
MaxDayInMonth = 29
Else
MaxDayInMonth = 28
End If 'divisible by 400
Else
MaxDayInMonth = 29
End If 'divisible by 100
Else
MaxDayInMonth = 28
End If 'divisible by 4
Case Else 'All the rest have 31
MaxDayInMonth = 31
End Select
End Function 'MaxDayInMonth()
'----------------------------------------------------------------------
' ChangeValue()
'----------------------------------------------------------------------
' Purpose: Changes the control's current value, checking if it's OK
' and doing the necessary notifications that it's changed
' Inputs: new day, month and year
' Outputs: none
'----------------------------------------------------------------------
Private Sub ChangeValue(nDay As Long, nMonth As Long, nYear As Long)
Dim rc As RECT 'used to invalidate smaller rects
'if only the day number changed
Dim fCancel As Boolean 'used in the WillChangeDate event
Dim dtOld As Date 'old date for raising in event
'give the developer a chance to cancel the date change
fCancel = False
RaiseEvent WillChangeDate(DateSerial(nYear, nMonth, nDay), fCancel)
If fCancel Then Exit Sub
'build a date using the current values
dtOld = DateSerial(mnYear, mnMonth, mnDay)
'check to see if it's OK to change the value
If UserControl.CanPropertyChange("Value") Then
'changing the month or year can make the day number
'invalid, so check the new combination and adjust the day
'if necessary.
If nDay > MaxDayInMonth(nMonth, nYear) Then
nDay = MaxDayInMonth(nMonth, nYear)
End If
'to avoid unecessary repainting, if only the day number changed
'just invalidate the two rects where the old and new dates are
If mnMonth = nMonth And mnYear = nYear Then
'setup a rect for the old day
rc.Left = LeftForDay(mnDay)
rc.Top = TopForDay(mnDay)
rc.Right = rc.Left + mcxColWidth
rc.Bottom = rc.Top + mcyRowHeight
'invalidate it
InvalidateRect UserControl.hwnd, rc, 0
'setup a rect for the new day
rc.Left = LeftForDay(nDay)
rc.Top = TopForDay(nDay)
rc.Right = rc.Left + mcxColWidth
rc.Bottom = rc.Top + mcyRowHeight
'invalidate it
InvalidateRect UserControl.hwnd, rc, 0
'since we are only changing the current day
'and not the current month or year, store off
'the specific days to repaint and set the
'fast repaint flag to true. This will cause the
'paint routing to just repaint these two days
'which makes the repaint considerably faster.
'The fast repaint is reset to False automatically.
maRepaintDays(0) = mnDay
maRepaintDays(1) = nDay
mfFastRepaint = True
'change the value and notify those interested
mnDay = nDay
Else
'reset the month and year navigators if they need to be
mfIgnoreMonthYearChange = True
If cbxMonth.ListIndex <> (nMonth - 1) Then cbxMonth.ListIndex = (nMonth - 1)
If Val(txtYear.Text) <> nYear Then txtYear.Text = nYear
mfIgnoreMonthYearChange = False
'change the value and notify those interested
mnDay = nDay
mnMonth = nMonth
mnYear = nYear
'refresh the entire calendar area since we have to
're-layout the days
InvalidateRect UserControl.hwnd, mrcCalArea, 0
End If 'just changing the day
'update the new focus area based on the new day selected
mrcFocusArea.Left = LeftForDay(mnDay) + FOCUSBORDER
mrcFocusArea.Top = TopForDay(mnDay) + FOCUSBORDER
mrcFocusArea.Right = mrcFocusArea.Left + mcxColWidth - (2 * FOCUSBORDER)
mrcFocusArea.Bottom = mrcFocusArea.Top + mcyRowHeight - (2 * FOCUSBORDER)
'update the window (usercontrol.refresh will invalidate
'everything so call UpdateWindow directly)
UpdateWindow UserControl.hwnd
'notify of the date change
UserControl.PropertyChanged "Value"
RaiseEvent DateChange(dtOld, DateSerial(mnYear, mnMonth, mnDay))
Else 'can't change prop
mobjRes.RaiseUserError errCantChange, Array("Value")
End If 'can change prop
End Sub 'ChangeValue()
'----------------------------------------------------------------------
' LeftForDay()
'----------------------------------------------------------------------
' Purpose: Returns the left (X) coodinate for a given day in the
' current month and year
' Inputs: day number
' Outputs: left coordinate
'----------------------------------------------------------------------
Private Function LeftForDay(nDay As Long) As Long
'the left coordinate for a given day is a function of the
'weekday (column number) of the day, the column width and
'the grid's left border
LeftForDay = ((WeekDay(DateSerial(mnYear, mnMonth, nDay), mnFirstDayOfWeek) - 1) _
* mcxColWidth) + mrcCalArea.Left
End Function 'LeftForDay()
'----------------------------------------------------------------------
' TopForDay()
'----------------------------------------------------------------------
' Purpose: Returns the top (Y) coodinate for a given day in the
' current month and year
' Inputs: day number
' Outputs: top coordinate
'----------------------------------------------------------------------
Private Function TopForDay(nDay As Long) As Long
Dim nRow As Long
'the top coordinate for a given day is a function of the
'row number of the day (day + column number of first day of month
'divided by number of columns), the row height, and the top of the
'entire grid
'we subtract 2 from the left side of the division since the
'weekday function is 1-based and since we need to subtract an
'additional one to make zero-base the day
nRow = (nDay + WeekDay(DateSerial(mnYear, mnMonth, 1), mnFirstDayOfWeek) - 2) \ NUMCOLS
TopForDay = (nRow * mcyRowHeight) + mrcCalArea.Top
End Function 'TopForDay()
'----------------------------------------------------------------------
' DateForRowCol()
'----------------------------------------------------------------------
' Purpose: Returns the Date for a given row and column in the
' current calendar grid
' Inputs: row and column number (zero-based)
' Outputs: corresponding date
'----------------------------------------------------------------------
Private Function DateForRowCol(nRow As Long, nCol As Long) As Date
Dim dtFirstDay As Date
Dim nColFirstDay As Long
Dim ctDaysDiff As Long
Debug.Assert (nRow < NUMROWS)
Debug.Assert (nCol < NUMCOLS)
'get the column for the first day of the current month
'first day is always in row 1
dtFirstDay = DateSerial(mnYear, mnMonth, 1)
nColFirstDay = WeekDay(dtFirstDay, mnFirstDayOfWeek) - 1
'how many days away is the current row and column?
ctDaysDiff = (nCol - nColFirstDay) + (NUMDAYS * nRow)
'calc the hit date by using date arithmetic
DateForRowCol = DateAdd("d", ctDaysDiff, dtFirstDay)
End Function 'DateForRowCol()
'----------------------------------------------------------------------
' GetPrevMonthDays()
'----------------------------------------------------------------------
' Purpose: Calculates the first and last day of the previous month
' that should be displayed before the first day of the
' of the given month and year
' Inputs: current month and year
' Outputs: first and last day of prev month to display
'----------------------------------------------------------------------
Private Sub GetPrevMonthDays(ByVal nCurMonth As Long, ByVal nCurYear As Long, nFirst As Long, nLast As Long)
Dim dtTemp As Date 'temp date
Dim nColDayOne As Long 'column of 1st day of cur month
'construct a date to do date math
dtTemp = DateSerial(nCurYear, nCurMonth, 1)
'determine the column of the first day of the current month
nColDayOne = WeekDay(dtTemp, mnFirstDayOfWeek)
'if the first day of the current month is in column 1, we
'don't need to paint any days from the prev month, so return
'zeros and -1 for the first and last value
If nColDayOne = 1 Then
nFirst = 0
nLast = -1
Else
'if there are days to paint, calculate the last and
'first day using date math
dtTemp = DateAdd("d", -1, dtTemp)
nLast = VBA.Day(dtTemp)
dtTemp = DateAdd("d", -(nColDayOne - 2), dtTemp)
nFirst = VBA.Day(dtTemp)
End If 'no days to paint
End Sub 'GetPrevMonthDays()
'----------------------------------------------------------------------
' LoadMonthNames()
'----------------------------------------------------------------------
' Purpose: Loads the names of the months into the month selector
' combo box
' Inputs: none
' Outputs: none
'----------------------------------------------------------------------
Private Sub LoadMonthNames()
Dim nMonth As Long
'use the format function to return the system specified
'long month name for each month
For nMonth = 1 To 12
masMonthNames(nMonth - 1) = Format(DateSerial(100, nMonth, 1), "mmmm")
cbxMonth.AddItem masMonthNames(nMonth - 1)
Next nMonth
End Sub 'LoadMonthNames()
'----------------------------------------------------------------------
' LoadDayNames()
'----------------------------------------------------------------------
' Purpose: Loads the names of the days into the day name string array
' Inputs: none
' Outputs: none
'----------------------------------------------------------------------
Private Sub LoadDayNames()
Dim nDay As Long
Dim sFormat As String
Select Case mnDayNameFormat
Case calShortName, calMediumName
sFormat = "ddd"
Case calLongName
sFormat = "dddd"
End Select
For nDay = 1 To 7
'if they want the short format, just take the first char
If mnDayNameFormat = calShortName Then
masDayNames(nDay - 1) = Left$(Format(DateSerial(1996, 8, 3 + nDay), sFormat), 1)
Else
masDayNames(nDay - 1) = Format(DateSerial(1996, 8, 3 + nDay), sFormat)
End If
Next nDay
End Sub 'LoadDayNames()
'----------------------------------------------------------------------
' CopyFont
'----------------------------------------------------------------------
' Purpose: Copies the contents of one StdFont object to another
' Inputs: source and destination StdFont object
' Outputs: none
'----------------------------------------------------------------------
Private Sub CopyFont(fntSource As StdFont, fntDest As StdFont)
'daveste -- 8/14/96
'REVIEW: Is there a better way to do this???!!!
'if the destination is nothing, create a new font object
If fntDest Is Nothing Then Set fntDest = New StdFont
fntDest.Bold = fntSource.Bold
fntDest.Charset = fntSource.Charset
fntDest.Italic = fntSource.Italic
fntDest.Name = fntSource.Name
fntDest.Size = fntSource.Size
fntDest.Strikethrough = fntSource.Strikethrough
fntDest.Underline = fntSource.Underline
fntDest.Weight = fntSource.Weight
End Sub 'CopyFont()
Reference in new issue View Git Blame Copy Permalink