home *** CD-ROM | disk | FTP | other *** search
/ Total C++ 2 / TOTALCTWO.iso / vb5.0 / tools / unsupprt / calendar / calendar.ctl < prev    next >
Text File  |  1997-01-16  |  75KB  |  1,937 lines
  1. VERSION 5.00
  2. Begin VB.UserControl Calendar 
  3.    ClientHeight    =   2745
  4.    ClientLeft      =   0
  5.    ClientTop       =   0
  6.    ClientWidth     =   3480
  7.    EditAtDesignTime=   -1  'True
  8.    KeyPreview      =   -1  'True
  9.    PropertyPages   =   "Calendar.ctx":0000
  10.    ScaleHeight     =   183
  11.    ScaleMode       =   3  'Pixel
  12.    ScaleWidth      =   232
  13.    ToolboxBitmap   =   "Calendar.ctx":0032
  14.    Begin VB.TextBox ctlFocus 
  15.       Height          =   285
  16.       Left            =   -300
  17.       TabIndex        =   0
  18.       Top             =   900
  19.       Width           =   150
  20.    End
  21.    Begin VB.TextBox txtYear 
  22.       Height          =   285
  23.       Left            =   2280
  24.       MaxLength       =   4
  25.       TabIndex        =   3
  26.       ToolTipText     =   "Year"
  27.       Top             =   120
  28.       Width           =   495
  29.    End
  30.    Begin VB.ComboBox cbxMonth 
  31.       Height          =   315
  32.       Left            =   480
  33.       Style           =   2  'Dropdown List
  34.       TabIndex        =   2
  35.       ToolTipText     =   "Month"
  36.       Top             =   120
  37.       Width           =   1695
  38.    End
  39.    Begin VB.CommandButton btnNext 
  40.       Height          =   255
  41.       Left            =   3060
  42.       MaskColor       =   &H000000FF&
  43.       Picture         =   "Calendar.ctx":012C
  44.       Style           =   1  'Graphical
  45.       TabIndex        =   4
  46.       ToolTipText     =   "Go To Next Month"
  47.       Top             =   120
  48.       UseMaskColor    =   -1  'True
  49.       Width           =   255
  50.    End
  51.    Begin VB.CommandButton btnPrev 
  52.       Height          =   255
  53.       Left            =   60
  54.       MaskColor       =   &H000000FF&
  55.       Picture         =   "Calendar.ctx":020E
  56.       Style           =   1  'Graphical
  57.       TabIndex        =   1
  58.       ToolTipText     =   "Go To Previous Month"
  59.       Top             =   120
  60.       UseMaskColor    =   -1  'True
  61.       Width           =   255
  62.    End
  63. End
  64. Attribute VB_Name = "Calendar"
  65. Attribute VB_GlobalNameSpace = False
  66. Attribute VB_Creatable = True
  67. Attribute VB_PredeclaredId = False
  68. Attribute VB_Exposed = True
  69. Attribute VB_Description = "VB Calendar Control Sample"
  70. '----------------------------------------------------------------------
  71. ' Calendar.ctl
  72. '----------------------------------------------------------------------
  73. ' Implementation file for the VB Calendar control sample.
  74. ' This control displays a month-at-a-time view calendar that the
  75. ' developer can use to let users view and adjust date values
  76. '----------------------------------------------------------------------
  77. ' Copyright (c) 1996, Microsoft Corporation
  78. '              All Rights Reserved
  79. '
  80. ' Information Contained Herin is Proprietary and Confidential
  81. '----------------------------------------------------------------------
  82. Option Explicit
  83.  
  84. '======================================================================
  85. ' Public Event Declarations
  86. '======================================================================
  87. Public Event DateChange(ByVal OldDate As Date, ByVal NewDate As Date)
  88. Public Event WillChangeDate(ByVal NewDate As Date, Cancel As Boolean)
  89. Public Event DblClick()
  90. Public Event Click()
  91.  
  92. '======================================================================
  93. ' Public Enumerations
  94. '======================================================================
  95. Public Enum CalendarMonths  'months of the year
  96.     calJanuary = 1
  97.     calFebruary
  98.     calMarch
  99.     calApril
  100.     calMay
  101.     calJune
  102.     calJuly
  103.     calAugust
  104.     calSeptember
  105.     calOctober
  106.     calNovember
  107.     calDecember
  108. End Enum 'CalendarMonths
  109.  
  110. Public Enum DaysOfTheWeek
  111.     calUseSystem = 0
  112.     calSunday
  113.     calMonday
  114.     calTuesday
  115.     calWednesday
  116.     calThursday
  117.     calFriday
  118.     calSaturday
  119. End Enum 'DaysOfTheWeek
  120.  
  121. Public Enum CalendarAreas
  122.     calNavigationArea
  123.     calDayNameArea
  124.     calDateArea
  125.     calUnknownArea
  126. End Enum 'CalendarAreas
  127.  
  128. 'Short = "F"
  129. 'Medium = "Fri"
  130. 'Long = "Friday"
  131. Public Enum DayNameFormats
  132.     calShortName = 0
  133.     calMediumName
  134.     calLongName
  135. End Enum 'DayNameFormats
  136.  
  137. '======================================================================
  138. ' Private Constants
  139. '======================================================================
  140. Private Const NUMCOLS As Long = 7           'number of cols in grid
  141. Private Const NUMROWS As Long = 6           'number of rows in grid
  142. Private Const NUMMONTHS As Long = 12        'number of months in a year
  143. Private Const NUMDAYS As Long = 7           'number of days in a week
  144. Private Const BORDER3D As Long = 2          'num pixels for good 3d border
  145. Private Const FOCUSBORDER As Long = 1       'num pixels for focus border
  146.  
  147. Private Enum DaySets
  148.     PrevMonthDays
  149.     CurMonthDays
  150.     NextMonthDays
  151. End Enum 'DaySets
  152.  
  153. Private Enum DayEffectFlags
  154.     calEffectOff = 1
  155.     calEffectOn = -1
  156.     calEffectDefault = 0
  157. End Enum 'DayEffectFlags
  158.  
  159. '======================================================================
  160. ' Private Data Members
  161. '======================================================================
  162. 'Current Date
  163. Private mnDay As Long               'current day number
  164. Private mnYear As Long              'current year number
  165. Private mnMonth As Long             'currnet month number
  166.  
  167. 'Formatting and Appearance Settings
  168. Private mnFirstDayOfWeek As VbDayOfWeek 'first day of the week
  169. Private mnDayNameFormat As DayNameFormats
  170. Private mfntDayNames As StdFont     'font to use for painting day names
  171. Private mclrDayNames As OLE_COLOR   'color for the day names
  172.  
  173. Private mfShowIterrators As Boolean 'determines if iterrator buttons
  174.                                     'should be shown or not
  175. Private mfMonthReadOnly As Boolean  'month selector or none
  176. Private mfYearReadOnly As Boolean  'month selector or none
  177.  
  178. 'Behavior settings
  179. Private mfLocked As Boolean         'read-only or not
  180.  
  181. 'String Arrays For Month and Day Names
  182. Private masMonthNames(NUMMONTHS - 1) As String 'string array of month names
  183. Private masDayNames(NUMDAYS - 1) As String   'string array of day names
  184.  
  185. 'this should be replaced with day styles eventually
  186. Private mfntDayFont As StdFont      'font to use for painting dates in
  187.                                     'the current month
  188. Private mclrDay As OLE_COLOR        'color for the day numbers
  189.  
  190. Private mafDayBold(1 To 31) As DayEffectFlags   'array of flags for day being bold
  191. Private mafDayItalic(1 To 31) As DayEffectFlags 'array of flags for day being italic
  192.  
  193. 'Current Column Width and Row Height For Calendar Grid
  194. Private mcxColWidth As Long         'width of each column in the grid
  195. Private mcyRowHeight As Long        'height of each row in the grid
  196.  
  197. 'RECTs For Different Calendar Areas
  198. Private mrcNavArea As RECT          'rect bounding the navigation area
  199. Private mrcDayNameArea As RECT      'rect bounding the day name area
  200. Private mrcCalArea As RECT          'area bounding the calendar days
  201. Private mrcFocusArea As RECT        'current focus area
  202.  
  203. 'General Utility Members
  204. Private mobjRes As ResLoader        'resource loading object (localization)
  205. Private mfIgnoreMonthYearChange As Boolean  'HACKY flag for ignoring the programatic
  206.                                             'change of the month and year navigation
  207.                                             'controls.
  208. Private maRepaintDays(1) As Long    'array of day numbers to repaint
  209. Private mfFastRepaint As Boolean    'boolean flag used to do fast repaint
  210.                                     'when only the day selected is changing
  211.  
  212. '======================================================================
  213. ' Public Property Procedures
  214. '======================================================================
  215.  
  216. '----------------------------------------------------------------------
  217. ' Version Get
  218. '----------------------------------------------------------------------
  219. ' Purpose:  Gets the version number of the control
  220. '----------------------------------------------------------------------
  221. Public Property Get Version() As String
  222. Attribute Version.VB_Description = "Returns the version number of this control."
  223. Attribute Version.VB_ProcData.VB_Invoke_Property = ";Misc"
  224.     Version = App.Major & "." & App.Minor & "." & App.Revision
  225. End Property 'Get Version()
  226.  
  227. '----------------------------------------------------------------------
  228. ' Day Get/Let
  229. '----------------------------------------------------------------------
  230. ' Purpose:  Gets and lets the current day value
  231. '----------------------------------------------------------------------
  232. Public Property Get Day() As Long
  233. Attribute Day.VB_Description = "Returns/Sets the Day number of the selected date."
  234. Attribute Day.VB_ProcData.VB_Invoke_Property = ";Data"
  235.     Day = mnDay
  236. End Property 'Get Day()
  237.  
  238. Public Property Let Day(nNewVal As Long)
  239.     'validate our inputs
  240.     If nNewVal > 0 And nNewVal <= MaxDayInMonth(mnMonth, mnYear) Then
  241.         ChangeValue nNewVal, mnMonth, mnYear
  242.     Else
  243.         mobjRes.RaiseUserError errPropValueRange, Array("Day", "0", CStr(MaxDayInMonth(mnMonth, mnYear)))
  244.     End If
  245. End Property 'Let Day()
  246.  
  247. '----------------------------------------------------------------------
  248. ' Month Get/Let
  249. '----------------------------------------------------------------------
  250. ' Purpose:  Gets and lets the current month value
  251. '----------------------------------------------------------------------
  252. Public Property Get Month() As CalendarMonths
  253. Attribute Month.VB_Description = "Returns/Sets the month number of the currently selected date."
  254. Attribute Month.VB_ProcData.VB_Invoke_Property = ";Data"
  255.     Month = mnMonth
  256. End Property 'Get Month()
  257.  
  258. Public Property Let Month(nNewVal As CalendarMonths)
  259.     'validate our inputs
  260.     'note we still need to do this even though we're using
  261.     'an enumeration since VB only treats this as a long value
  262.     If nNewVal > 0 And nNewVal <= 12 Then
  263.         ChangeValue mnDay, nNewVal, mnYear
  264.     Else
  265.         mobjRes.RaiseUserError errPropValueRange, Array("Month", "0", "12")
  266.     End If
  267. End Property 'Let Month()
  268.  
  269. '----------------------------------------------------------------------
  270. ' Year Get/Let
  271. '----------------------------------------------------------------------
  272. ' Purpose:  Gets and lets the current year value
  273. '----------------------------------------------------------------------
  274. Public Property Get Year() As Long
  275. Attribute Year.VB_Description = "Returns/Sets the year number of the currently selected date."
  276. Attribute Year.VB_ProcData.VB_Invoke_Property = ";Data"
  277.     Year = mnYear
  278. End Property 'Get Year()
  279.  
  280. Public Property Let Year(nNewVal As Long)
  281.     'validate our inputs
  282.     'year must be between 100 and 9999 due to the restrictions
  283.     'of the date data type in basic
  284.     If nNewVal >= 100 And nNewVal <= 9999 Then
  285.         ChangeValue mnDay, mnMonth, nNewVal
  286.     Else
  287.         mobjRes.RaiseUserError errPropValueRange, Array("Year", "100", "9999")
  288.     End If
  289. End Property 'Let Year()
  290.  
  291. '----------------------------------------------------------------------
  292. ' Value Get/Let
  293. '----------------------------------------------------------------------
  294. ' Purpose:  Gets and lets the current date value
  295. '----------------------------------------------------------------------
  296. Public Property Get Value() As Date
  297. Attribute Value.VB_Description = "Returns/Sets the currently selected date in the control."
  298. Attribute Value.VB_ProcData.VB_Invoke_Property = ";Data"
  299. Attribute Value.VB_MemberFlags = "3c"
  300.     Value = DateSerial(mnYear, mnMonth, mnDay)
  301. End Property 'Get Value()
  302.  
  303. Public Property Let Value(dtNew As Date)
  304.     ChangeValue VBA.Day(dtNew), VBA.Month(dtNew), VBA.Year(dtNew)
  305. End Property 'Let Value()
  306.  
  307.  
  308. '----------------------------------------------------------------------
  309. ' DayFont Get/Set
  310. '----------------------------------------------------------------------
  311. ' Purpose:  Gets or sets the font to use for date numbers
  312. '----------------------------------------------------------------------
  313. Public Property Get DayFont() As Font
  314. Attribute DayFont.VB_Description = "Returns/Sets the font used for the day numbers."
  315. Attribute DayFont.VB_ProcData.VB_Invoke_Property = ";Appearance"
  316. Attribute DayFont.VB_UserMemId = -512
  317.     Set DayFont = mfntDayFont
  318. End Property 'Get DayFont()
  319.  
  320. '*** VB BUG Workaround ***
  321. 'The fntNew argument is passed in ByVal in order to
  322. 'get this property to show in the built-in Font
  323. 'property page.  When the bug is fixed, change this
  324. 'back to ByRef (remove ByVal)
  325. Public Property Set DayFont(ByVal fntNew As Font)
  326.     Set mfntDayFont = fntNew
  327.     
  328.     UserControl.Refresh
  329. End Property 'Set DayFont()
  330.  
  331. '----------------------------------------------------------------------
  332. ' DayNameFont Get/Set
  333. '----------------------------------------------------------------------
  334. ' Purpose:  Gets or sets the font to use for day names
  335. '----------------------------------------------------------------------
  336. Public Property Get DayNameFont() As Font
  337. Attribute DayNameFont.VB_Description = "Returns/Sets the font used for the day names."
  338. Attribute DayNameFont.VB_ProcData.VB_Invoke_Property = ";Appearance"
  339.     Set DayNameFont = mfntDayNames
  340. End Property 'Get DayFont()
  341.  
  342. '*** VB BUG Workaround ***
  343. 'The fntNew argument is passed in ByVal in order to
  344. 'get this property to show in the built-in Font
  345. 'property page.  When the bug is fixed, change this
  346. 'back to ByRef (remove ByVal)
  347. Public Property Set DayNameFont(ByVal fntNew As Font)
  348.     Set mfntDayNames = fntNew
  349.     UserControl.Refresh
  350. End Property 'Set DayFont()
  351.  
  352. '----------------------------------------------------------------------
  353. ' DayBold() Get/Let
  354. '----------------------------------------------------------------------
  355. ' Purpose:  This property allows the user to set a particular day to bold
  356. '           or not so as to give the effect of a 'special' day
  357. ' Inputs:   day number (1 to max day in current month)
  358. ' Outputs:  True if it's Bold, False if not
  359. '----------------------------------------------------------------------
  360. Public Property Get DayBold(DayNumber As Long) As Boolean
  361. Attribute DayBold.VB_Description = "Returns/Sets the Bold state for a day in the current month."
  362.     'if the setting for this day is "default" then the
  363.     'value returned depends on the bold state of the
  364.     'DayFont property
  365.     If mafDayBold(DayNumber) = calEffectDefault Then
  366.         DayBold = mfntDayFont.Bold
  367.     Else
  368.         DayBold = (mafDayBold(DayNumber) = calEffectOn)
  369.     End If
  370. End Property 'Get DayBold()
  371.  
  372. Public Property Let DayBold(DayNumber As Long, NewVal As Boolean)
  373.     If NewVal = True Then
  374.         mafDayBold(DayNumber) = calEffectOn
  375.     Else
  376.         mafDayBold(DayNumber) = calEffectOff
  377.     End If
  378. End Property 'Let DayBold()
  379.  
  380. '----------------------------------------------------------------------
  381. ' DayItalic() Get/Let
  382. '----------------------------------------------------------------------
  383. ' Purpose:  This property allows the user to set a particular day italic
  384. '           or not so as to give the effect of a 'special' day
  385. ' Inputs:   day number (1 to max day in current month)
  386. ' Outputs:  True if it's Italic, False if not
  387. '----------------------------------------------------------------------
  388. Public Property Get DayItalic(DayNumber As Long) As Boolean
  389. Attribute DayItalic.VB_Description = "Returns/Sets the Italic state for a day in the current month."
  390.     'if the setting for this day is "default" then the
  391.     'value returned depends on the italic state of the
  392.     'DayFont property
  393.     If mafDayItalic(DayNumber) = calEffectDefault Then
  394.         DayItalic = mfntDayFont.Italic
  395.     Else
  396.         DayItalic = (mafDayItalic(DayNumber) = calEffectOn)
  397.     End If
  398. End Property 'Get DayItalic()
  399.  
  400. '**Let
  401. Public Property Let DayItalic(DayNumber As Long, NewVal As Boolean)
  402.     If NewVal = True Then
  403.         mafDayItalic(DayNumber) = calEffectOn
  404.     Else
  405.         mafDayItalic(DayNumber) = calEffectOff
  406.     End If
  407. End Property 'Let DayItalic()
  408.  
  409. '----------------------------------------------------------------------
  410. ' StartOfWeek Get/Let
  411. '----------------------------------------------------------------------
  412. ' Purpose:  Gets or lets the first day to display in a week
  413. '----------------------------------------------------------------------
  414. Public Property Get StartOfWeek() As DaysOfTheWeek
  415. Attribute StartOfWeek.VB_Description = "Returns/Sets the first day of the week which will be displayed in the left-most column."
  416. Attribute StartOfWeek.VB_ProcData.VB_Invoke_Property = ";Appearance"
  417.     StartOfWeek = mnFirstDayOfWeek
  418. End Property 'Get StartOfWeek()
  419.  
  420. Public Property Let StartOfWeek(nNewVal As DaysOfTheWeek)
  421.     'validate our inputs
  422.     If nNewVal >= calUseSystem And nNewVal <= calSaturday Then
  423.         mnFirstDayOfWeek = nNewVal
  424.         
  425.         'do a Refresh to make the control repaint
  426.         UserControl.Refresh
  427.         
  428.     Else
  429.         mobjRes.RaiseUserError errPropValueRange, Array("StartOfWeek", calUseSystem, calSaturday)
  430.     End If 'valid inputs
  431.     
  432. End Property 'Let StartOfWeek()
  433.  
  434. '----------------------------------------------------------------------
  435. ' DayNameFormat Get/Let
  436. '----------------------------------------------------------------------
  437. ' Purpose:  Gets or lets the format to use for day names
  438. '           (short, medium, long)
  439. '----------------------------------------------------------------------
  440. Public Property Get DayNameFormat() As DayNameFormats
  441. Attribute DayNameFormat.VB_Description = "Returns/Sets the format to use for the day names (Short = ""M"", Medium = ""Mon"", Long = ""Monday"")."
  442. Attribute DayNameFormat.VB_ProcData.VB_Invoke_Property = ";Appearance"
  443.     DayNameFormat = mnDayNameFormat
  444. End Property 'Get DayNameFormat
  445.  
  446. Public Property Let DayNameFormat(nNewFormat As DayNameFormats)
  447.     'validate the input
  448.     If nNewFormat >= calShortName And nNewFormat <= calLongName Then
  449.         'set the new format and re-load the day names
  450.         mnDayNameFormat = nNewFormat
  451.         LoadDayNames
  452.         UserControl.Refresh
  453.     Else
  454.         mobjRes.RaiseUserError errPropValueRange, Array("DayNameFormat", calShortName, calLongName)
  455.     End If 'valid inputs
  456. End Property 'Let DayNameFormat
  457.  
  458. '----------------------------------------------------------------------
  459. ' ShowIterratorButtons Get/Let
  460. '----------------------------------------------------------------------
  461. ' Purpose:  Gets or lets the option for showing or hiding the month
  462. '           iterrator buttons
  463. '----------------------------------------------------------------------
  464. Public Property Get ShowIterrationButtons() As Boolean
  465. Attribute ShowIterrationButtons.VB_Description = "Returns/Sets the visible state of the previous and next month navigation buttons."
  466. Attribute ShowIterrationButtons.VB_ProcData.VB_Invoke_Property = ";Appearance"
  467.     ShowIterrationButtons = mfShowIterrators
  468. End Property 'Get ShowIterrationButtons()
  469.  
  470. Public Property Let ShowIterrationButtons(fNew As Boolean)
  471.     'if it's not changing, don't bother
  472.     If fNew = mfShowIterrators Then Exit Property
  473.     
  474.     'assign the new value
  475.     mfShowIterrators = fNew
  476.     
  477.     'and adjust the visible state of the buttons
  478.     btnPrev.Visible = mfShowIterrators
  479.     btnNext.Visible = mfShowIterrators
  480.     
  481.     'trigger the resize event to recalc the widths
  482.     'of the other navigation controls
  483.     UserControl_Resize
  484. End Property 'Let ShowIterrationButtons()
  485.  
  486. '----------------------------------------------------------------------
  487. ' MonthReadOnly Get/Let
  488. '----------------------------------------------------------------------
  489. ' Purpose:  Gets and lets the option of making the month selector
  490. '           read-only or not
  491. '----------------------------------------------------------------------
  492. Public Property Get MonthReadOnly() As Boolean
  493. Attribute MonthReadOnly.VB_Description = "Returns/Sets the read-only state of the month navigation combo box."
  494. Attribute MonthReadOnly.VB_ProcData.VB_Invoke_Property = ";Appearance"
  495.     MonthReadOnly = mfMonthReadOnly
  496. End Property 'Get MonthReadOnly()
  497.  
  498. Public Property Let MonthReadOnly(fNew As Boolean)
  499.     'if it's not changing, don't bother
  500.     If fNew = mfMonthReadOnly Then Exit Property
  501.     
  502.     'set the new value and hide or show the month selector
  503.     mfMonthReadOnly = fNew
  504.     cbxMonth.Visible = Not mfMonthReadOnly
  505. End Property 'Let MonthReadOnly()
  506.  
  507. '----------------------------------------------------------------------
  508. ' YearReadOnly Get/Let
  509. '----------------------------------------------------------------------
  510. ' Purpose:  Gets and lets the option of making the year selector
  511. '           read-only or not
  512. '----------------------------------------------------------------------
  513. Public Property Get YearReadOnly() As Boolean
  514. Attribute YearReadOnly.VB_Description = "Returns/Sets the read-only state of the year navigation text box."
  515. Attribute YearReadOnly.VB_ProcData.VB_Invoke_Property = ";Appearance"
  516.     YearReadOnly = mfYearReadOnly
  517. End Property 'Get YearReadOnly()
  518.  
  519. Public Property Let YearReadOnly(fNew As Boolean)
  520.     'if it's not changing, don't bother
  521.     If fNew = mfYearReadOnly Then Exit Property
  522.     
  523.     'set the new value and hide or show the month selector
  524.     mfYearReadOnly = fNew
  525.     txtYear.Visible = Not mfYearReadOnly
  526. End Property 'Let YearReadOnly()
  527.  
  528. '----------------------------------------------------------------------
  529. ' Locked Get/Let
  530. '----------------------------------------------------------------------
  531. ' Purpose:  Gets and sets the Locked option which makes the whole thing
  532. '           read-only or not
  533. '----------------------------------------------------------------------
  534. Public Property Get Locked() As Boolean
  535. Attribute Locked.VB_Description = "Returns/Sets the locked state of the control.  When locked, the user cannot change the selected date."
  536. Attribute Locked.VB_ProcData.VB_Invoke_Property = ";Behavior"
  537.     Locked = mfLocked
  538. End Property 'Get Locked()
  539.  
  540. Public Property Let Locked(fNew As Boolean)
  541.     
  542.     'set the private variable
  543.     mfLocked = fNew
  544.     
  545.     'set the locked state of contained controls
  546.     'we'll disable the buttons if locked since
  547.     'there is no locked state for buttons
  548.     cbxMonth.Locked = fNew
  549.     txtYear.Locked = fNew
  550.     btnNext.Enabled = Not fNew
  551.     btnPrev.Enabled = Not fNew
  552.     
  553. End Property 'Let Locked()
  554.  
  555. '----------------------------------------------------------------------
  556. ' DayColor Get/Let
  557. '----------------------------------------------------------------------
  558. ' Purpose:  Gets and sets the color used for the day numbers
  559. '----------------------------------------------------------------------
  560. Public Property Get DayColor() As OLE_COLOR
  561. Attribute DayColor.VB_Description = "Returns/Sets the color used for the day numbers."
  562. Attribute DayColor.VB_ProcData.VB_Invoke_Property = ";Appearance"
  563. Attribute DayColor.VB_UserMemId = -513
  564.     DayColor = mclrDay
  565. End Property 'Get DayColor()
  566.  
  567. Public Property Let DayColor(NewVal As OLE_COLOR)
  568.     mclrDay = NewVal
  569.     UserControl.Refresh
  570. End Property 'Let DayColor()
  571.  
  572. '----------------------------------------------------------------------
  573. ' DayNameColor Get/Let
  574. '----------------------------------------------------------------------
  575. ' Purpose:  Gets and sets the color used for the day numbers
  576. '----------------------------------------------------------------------
  577. Public Property Get DayNameColor() As OLE_COLOR
  578. Attribute DayNameColor.VB_Description = "Returns/Sets the color used for the day names (i.e. days of the week)."
  579. Attribute DayNameColor.VB_ProcData.VB_Invoke_Property = ";Appearance"
  580.     DayColor = mclrDayNames
  581. End Property 'Get DayNameColor()
  582.  
  583. Public Property Let DayNameColor(NewVal As OLE_COLOR)
  584.     mclrDayNames = NewVal
  585.     UserControl.Refresh
  586. End Property 'Let DayNameColor()
  587.  
  588.  
  589.  
  590. '======================================================================
  591. ' Public Methods
  592. '======================================================================
  593.  
  594. '----------------------------------------------------------------------
  595. ' HitTest()
  596. '----------------------------------------------------------------------
  597. ' Purpose:  Does a hit test based on x,y coordinates
  598. ' Inputs:   x and y coordinates
  599. ' Outputs:  Area of the control and specific date if over one
  600. '----------------------------------------------------------------------
  601. Public Sub HitTest(ByVal X As Long, ByVal Y As Long, Area As Long, HitDate As Date)
  602. Attribute HitTest.VB_Description = "Returns the area and day number (if any) that corresponds to a given X,Y position."
  603.     Dim nRow As Long
  604.     Dim nCol As Long
  605.     
  606.     'assert that the x and y are indeed in our coordinate system
  607.     Debug.Assert (X <= UserControl.ScaleWidth)
  608.     Debug.Assert (Y <= UserControl.ScaleHeight)
  609.     
  610.     'determine the area of the control that x and y are over
  611.     If X > mrcNavArea.Right Then
  612.         Area = calUnknownArea
  613.     Else
  614.         If Y >= mrcNavArea.Top And Y <= mrcNavArea.Bottom Then
  615.             Area = calNavigationArea
  616.         ElseIf Y >= mrcDayNameArea.Top And Y <= mrcDayNameArea.Bottom Then
  617.             Area = calDayNameArea
  618.         ElseIf Y >= mrcCalArea.Top And Y <= mrcCalArea.Bottom Then
  619.             Area = calDateArea
  620.         Else
  621.             Area = calUnknownArea
  622.         End If 'determine area by y
  623.     End If 'x is past right of all areas
  624.     
  625.     'if we are in the date area, calculate the hit date
  626.     If Area = calDateArea Then
  627.         
  628.         'determine the row and column and make them 0-based
  629.         nRow = ((Y - mrcCalArea.Top) \ mcyRowHeight) - 1
  630.         If (Y - mrcCalArea.Top) Mod mcyRowHeight > 0 Then
  631.             nRow = nRow + 1
  632.         End If
  633.         
  634.         nCol = ((X - mrcCalArea.Left) \ mcxColWidth) - 1
  635.         If (X - mrcCalArea.Left) Mod mcxColWidth > 0 Then
  636.             nCol = nCol + 1
  637.         End If
  638.         
  639.         'given the row and column, determine the date
  640.         HitDate = DateForRowCol(nRow, nCol)
  641.         
  642.     End If 'in date area
  643.  
  644. End Sub 'HitTest
  645.  
  646. '----------------------------------------------------------------------
  647. ' Refresh()
  648. '----------------------------------------------------------------------
  649. ' Purpose:  Refreshes/repaints the entire control
  650. ' Inputs:   none
  651. ' Outputs:  none
  652. '----------------------------------------------------------------------
  653. Public Sub Refresh()
  654. Attribute Refresh.VB_Description = "Refreshes the control by causing a complete repaint."
  655.     'just pass it on...
  656.     UserControl.Refresh
  657. End Sub 'Refresh()
  658.  
  659. '----------------------------------------------------------------------
  660. ' About()
  661. '----------------------------------------------------------------------
  662. ' Purpose:  Opens the About box for the control--this is marked hidden
  663. '           so that it doesn't show up in the statement completion
  664. '           but we do mark this with the DispID of AboutBox so that it
  665. '           shows in the property sheet with an elipsis button
  666. ' Inputs:   none
  667. ' Outputs:  none
  668. '----------------------------------------------------------------------
  669. Public Sub About()
  670. Attribute About.VB_Description = "Shows the about box for the control."
  671. Attribute About.VB_UserMemId = -552
  672. Attribute About.VB_MemberFlags = "40"
  673.     frmAbout.Show vbModal
  674. End Sub 'About()
  675.  
  676.  
  677. '======================================================================
  678. ' Initialize and Terminate Events
  679. '======================================================================
  680. Private Sub UserControl_Initialize()
  681.     
  682.     On Error GoTo Err_Init
  683.     
  684.     'set the resource loader
  685.     'daveste -- 7/31/96
  686.     'TODO: put in code to load a satellite resource DLL based on the
  687.     'locale ID of the ambient host
  688.     Set mobjRes = New ResLoader
  689.     
  690.     'load the month names into the combo box
  691.     LoadMonthNames
  692.     
  693.     'initialize the area rects that don't depend on the
  694.     'size of the control (which are left and top and sometimes bottom)
  695.     'doing this here lets us reduce the code needed to execute
  696.     'when the control is resized which will happen more often
  697.     'than the control being initialized.
  698.     mrcNavArea.Left = 1
  699.     mrcNavArea.Top = 1
  700.     
  701.     'height of navigation area is the height of the month combo
  702.     'plus 4, since we will draw a 3d box around the controls
  703.     mrcNavArea.Bottom = cbxMonth.Height + (2 * BORDER3D)
  704.     mrcDayNameArea.Left = 1
  705.     mrcDayNameArea.Top = mrcNavArea.Bottom
  706.     
  707.     'height of the day name area should be the height of
  708.     'the day name font plus 6 pixels for 3d effects
  709.     mrcDayNameArea.Bottom = mrcDayNameArea.Top + UserControl.TextHeight("A") + 6
  710.     
  711.     mrcCalArea.Left = 1
  712.     mrcCalArea.Top = mrcDayNameArea.Bottom
  713.     
  714.     'set the position and sizes of the navigation controls that
  715.     'don't depend on the size of the control (like left and top
  716.     'values).
  717.     btnPrev.Move mrcNavArea.Left, mrcNavArea.Top, btnPrev.Width, mrcNavArea.Bottom - mrcNavArea.Top
  718.     
  719.     btnNext.Top = mrcNavArea.Top
  720.     btnNext.Height = mrcNavArea.Bottom - mrcNavArea.Top
  721.     
  722.     cbxMonth.Move mrcNavArea.Left + btnPrev.Width + BORDER3D, mrcNavArea.Top + BORDER3D
  723.     txtYear.Height = cbxMonth.Height
  724.     txtYear.Top = mrcNavArea.Top + BORDER3D
  725.     
  726.     'set the disabled picture for the prev and next buttons
  727.     'to be the same as the regular picture--this will let us
  728.     'give a locked effect by disabling the prev and next buttons
  729.     btnPrev.DisabledPicture = btnPrev.Picture
  730.     btnNext.DisabledPicture = btnNext.Picture
  731.     
  732.     Exit Sub
  733.  
  734. Err_Init:
  735.     Debug.Assert False
  736.     Exit Sub
  737. End Sub 'UserControl_Initialize()
  738.  
  739. '======================================================================
  740. ' Private Event Handles
  741. '======================================================================
  742.  
  743. '----------------------------------------------------------------------
  744. ' InitProperties Event
  745. '----------------------------------------------------------------------
  746. ' Purpose:  Called when the control is first put on a form
  747. '           One-time initialization of data members
  748. ' Inputs:   None
  749. ' Outputs:  None
  750. '----------------------------------------------------------------------
  751. Private Sub UserControl_InitProperties()
  752.     Dim dt As Date
  753.         
  754.     On Error GoTo Err_InitProps
  755.     
  756.     'initialize the day, month and year to the current system date
  757.     dt = Date
  758.     mnDay = VBA.Day(dt)
  759.     mnMonth = VBA.Month(dt)
  760.     mnYear = VBA.Year(dt)
  761.     
  762.     mfIgnoreMonthYearChange = True
  763.     cbxMonth.ListIndex = mnMonth - 1
  764.     txtYear.Text = mnYear
  765.     mfIgnoreMonthYearChange = False
  766.     
  767.     'create new font objects for the day and day name
  768.     'fonts and copy the font attributes from the
  769.     'user control's ambient font into them
  770.     Set mfntDayFont = New StdFont
  771.     CopyFont UserControl.Ambient.Font, mfntDayFont
  772.     
  773.     Set mfntDayNames = New StdFont
  774.     CopyFont UserControl.Ambient.Font, mfntDayNames
  775.     mfntDayNames.Bold = True
  776.     
  777.     'initialize the day and dayname colors to the ambient's
  778.     'fore color value
  779.     mclrDay = vbBlack
  780.     mclrDayNames = vbBlack
  781.     
  782.     'initialize the day name format to medium
  783.     mnDayNameFormat = calMediumName
  784.     LoadDayNames
  785.     
  786.     'init various appearance options
  787.     mfShowIterrators = True
  788.     mfMonthReadOnly = False
  789.     mfYearReadOnly = False
  790.     mfLocked = False
  791.     
  792.     Exit Sub
  793.  
  794. Err_InitProps:
  795.     Debug.Assert False
  796.     Exit Sub
  797. End Sub 'UserControl_InitProperties()
  798.  
  799. '----------------------------------------------------------------------
  800. ' ReadProperties Event
  801. '----------------------------------------------------------------------
  802. ' Purpose:  Called when we need to read property settings back in
  803. ' Inputs:   the property bag class for reading
  804. ' Outputs:  None
  805. '----------------------------------------------------------------------
  806. Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  807.     Dim dtCurrent As Date
  808.     dtCurrent = Date
  809.     
  810.     On Error Resume Next
  811.     'read in the properties from the property bag
  812.     mnFirstDayOfWeek = PropBag.ReadProperty("StartOfWeek", vbUseSystemDayOfWeek)
  813.     
  814.     ChangeValue PropBag.ReadProperty("Day", VBA.Day(dtCurrent)), _
  815.                 PropBag.ReadProperty("Month", VBA.Month(dtCurrent)), _
  816.                 PropBag.ReadProperty("Year", VBA.Year(dtCurrent))
  817.     
  818.     Set mfntDayNames = PropBag.ReadProperty("DayNameFont", UserControl.Font)
  819.     Set mfntDayFont = PropBag.ReadProperty("DayFont", UserControl.Font)
  820.     
  821.     mclrDay = PropBag.ReadProperty("DayColor", vbBlack)
  822.     mclrDayNames = PropBag.ReadProperty("DayNameColor", vbBlack)
  823.     
  824.     mnDayNameFormat = PropBag.ReadProperty("DayNameFormat", calMediumName)
  825.     LoadDayNames
  826.     
  827.     Me.ShowIterrationButtons = PropBag.ReadProperty("ShowIterrationButtons", True)
  828.     Me.MonthReadOnly = PropBag.ReadProperty("MonthReadOnly", False)
  829.     Me.YearReadOnly = PropBag.ReadProperty("YearReadOnly", False)
  830.     Me.Locked = PropBag.ReadProperty("Locked", False)
  831.     
  832.     'trigger a resize since this event happens after the initial
  833.     'resize when going to run mode
  834.     UserControl_Resize
  835.     
  836. End Sub 'UserControl_ReadProperties()
  837.  
  838. '----------------------------------------------------------------------
  839. ' WriteProperties Event
  840. '----------------------------------------------------------------------
  841. ' Purpose:  Called when we need to write property settings out to disk
  842. ' Inputs:   the property bag class for writing
  843. ' Outputs:  None
  844. '----------------------------------------------------------------------
  845. Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  846.     On Error Resume Next
  847.     
  848.     'write the current property values to the property bag
  849.     PropBag.WriteProperty "Day", mnDay
  850.     PropBag.WriteProperty "Month", mnMonth
  851.     PropBag.WriteProperty "Year", mnYear
  852.     
  853.     PropBag.WriteProperty "StartOfWeek", mnFirstDayOfWeek, vbUseSystemDayOfWeek
  854.     PropBag.WriteProperty "DayNameFont", mfntDayNames, UserControl.Font
  855.     PropBag.WriteProperty "DayFont", mfntDayFont, UserControl.Font
  856.     PropBag.WriteProperty "DayNameFormat", mnDayNameFormat, calMediumName
  857.     PropBag.WriteProperty "DayColor", mclrDay, vbBlack
  858.     PropBag.WriteProperty "DayNameColor", mclrDayNames, vbBlack
  859.     
  860.     
  861.     PropBag.WriteProperty "ShowIterrationButtons", mfShowIterrators, True
  862.     PropBag.WriteProperty "MonthReadOnly", mfMonthReadOnly, False
  863.     PropBag.WriteProperty "YearReadOnly", mfYearReadOnly, False
  864.     PropBag.WriteProperty "Locked", mfLocked, False
  865.     
  866. End Sub 'UserControl_WriteProperties()
  867.  
  868. '----------------------------------------------------------------------
  869. ' Paint Event
  870. '----------------------------------------------------------------------
  871. ' Purpose:  Called when the control needs to be repainted
  872. ' Inputs:   None
  873. ' Outputs:  None
  874. '----------------------------------------------------------------------
  875. Private Sub UserControl_Paint()
  876.     Dim dcWork As OffScreenDC
  877.     
  878.     Dim nTop As Long
  879.     Dim nLeft As Long
  880.     Dim nWidth As Long
  881.     Dim nHeight As Long
  882.     
  883.     Dim nDay As Long
  884.     Dim nRow As Long
  885.     Dim nCol As Long
  886.     Dim nLastDay As Long
  887.     Dim eDaySet As DaySets
  888.     Dim rgbColor As Long
  889.     Dim fDefBold As Boolean
  890.     Dim fDefItalic As Boolean
  891.     
  892.     On Error GoTo Err_Paint
  893.     
  894.     'save the initial bold and italic state of our day font
  895.     fDefBold = mfntDayFont.Bold
  896.     fDefItalic = mfntDayFont.Italic
  897.     
  898.     Set dcWork = New OffScreenDC
  899.     
  900.     dcWork.Initialize UserControl.hdc, UserControl.ScaleWidth, UserControl.ScaleHeight
  901.     
  902.     'set the text color to be the color chosen for
  903.     'the days of the week names
  904.     OleTranslateColor mclrDayNames, 0, rgbColor
  905.     dcWork.TextColor = rgbColor
  906.     
  907.     If mfFastRepaint Then
  908.         FastRepaint dcWork
  909.         Exit Sub
  910.     End If
  911.     
  912.     'fill the background of the control with the ambient's
  913.     'background color
  914.     nLeft = 0
  915.     nTop = 0
  916.     nWidth = UserControl.ScaleWidth
  917.     nHeight = UserControl.ScaleHeight
  918.     
  919.     'I use the OLE API OleTranslateColor here to translate
  920.     'an OLE color to an RGB value.  VB will return an OLE color
  921.     'value for the ambient's back color and this API will convert
  922.     'it to an RGB value for painting.
  923.     OleTranslateColor UserControl.Ambient.BackColor, 0, rgbColor
  924.     
  925.     dcWork.FillRect nLeft, nTop, nWidth, nHeight, rgbColor
  926.     
  927.     'next fill a black rect that will serve as a thin back outline
  928.     'around the painted part of the control
  929.     nWidth = mrcNavArea.Right + 1
  930.     nHeight = mrcDayNameArea.Bottom + (mcyRowHeight * NUMROWS) + 1
  931.     dcWork.FillRect 0, 0, nWidth, nHeight, vbBlack
  932.     
  933.     'draw a 3d rect around the navigation controls
  934.     nTop = mrcNavArea.Top
  935.     nHeight = mrcNavArea.Bottom - mrcNavArea.Top
  936.     
  937.     If mfShowIterrators Then
  938.         nLeft = mrcNavArea.Left + btnPrev.Width
  939.         nWidth = btnNext.Left - nLeft
  940.     Else
  941.         nLeft = mrcNavArea.Left
  942.         nWidth = mrcNavArea.Right - mrcNavArea.Left
  943.     End If 'mfShowIterrators
  944.     
  945.     dcWork.Draw3DRect nLeft, nTop, nWidth, nHeight
  946.     
  947.     'if the month is read only, draw the month name
  948.     If mfMonthReadOnly Then
  949.         Set dcWork.Font = cbxMonth.Font
  950.         
  951.         'squeeze the width in by one to make a better 3d effect
  952.         dcWork.Draw3DRect cbxMonth.Left, cbxMonth.Top, _
  953.                             cbxMonth.Width - 1, cbxMonth.Height, _
  954.                             cbxMonth.List(cbxMonth.ListIndex), _
  955.                             caCenterCenter, Sunken
  956.     End If 'month is read only
  957.     
  958.     'if the year is read only, draw the year number
  959.     If mfYearReadOnly Then
  960.         Set dcWork.Font = txtYear.Font
  961.         
  962.         dcWork.Draw3DRect txtYear.Left, txtYear.Top, _
  963.                             txtYear.Width, txtYear.Height, _
  964.                             txtYear.Text, caCenterCenter, Sunken
  965.     End If 'year is read only
  966.     
  967.     'paint the day names
  968.     PaintDayNames dcWork
  969.     
  970.     'change the text color to dark gray to paint the previous month days
  971.     'daveste -- 7/31/96
  972.     'TODO: this should be replaced with day styles or at least with
  973.     'a property the control the font and color of these other dates
  974.     dcWork.TextColor = RGB(128, 128, 128)
  975.     
  976.     'get the first and last days of the previous month to paint
  977.     GetPrevMonthDays mnMonth, mnYear, nDay, nLastDay
  978.     eDaySet = PrevMonthDays
  979.     
  980.     Set dcWork.Font = mfntDayFont
  981.     
  982.     'draw a grid of date numbers for the current month
  983.     For nRow = 0 To NUMROWS - 1
  984.         For nCol = 0 To NUMCOLS - 1
  985.             
  986.             'if we've done painting the current set of days
  987.             'switch to the next set
  988.             If nDay > nLastDay Then
  989.                 If eDaySet = PrevMonthDays Then
  990.                     OleTranslateColor mclrDay, 0, rgbColor
  991.                     dcWork.TextColor = rgbColor
  992.                     nDay = 1
  993.                     nLastDay = MaxDayInMonth(mnMonth, mnYear)
  994.                     eDaySet = CurMonthDays
  995.                     
  996.                 Else
  997.                 
  998.                     dcWork.TextColor = RGB(128, 128, 128)
  999.                     nDay = 1
  1000.                     nLastDay = 100 'no need to calc the last
  1001.                                     'day since the for loops
  1002.                                     'will govern when to stop
  1003.                     eDaySet = NextMonthDays
  1004.                     
  1005.                 End If 'day set was previous month
  1006.             End If 'done painting this day set
  1007.             
  1008.             'paint the day
  1009.             
  1010.             'set the font attributes for the day being painted
  1011.             If eDaySet = CurMonthDays Then
  1012.                 If mafDayBold(nDay) = calEffectDefault Then
  1013.                     'optimize for the case where no days are bold
  1014.                     If mfntDayFont.Bold <> fDefBold Then
  1015.                         mfntDayFont.Bold = fDefBold
  1016.                         Set dcWork.Font = mfntDayFont
  1017.                     End If
  1018.                 Else
  1019.                     mfntDayFont.Bold = (mafDayBold(nDay) = calEffectOn)
  1020.                     Set dcWork.Font = mfntDayFont
  1021.                 End If 'DayBold setting is default
  1022.                 
  1023.                 If mafDayItalic(nDay) = calEffectDefault Then
  1024.                     'optimize for the case where no days are italic
  1025.                     If mfntDayFont.Italic <> fDefItalic Then
  1026.                         mfntDayFont.Italic = fDefItalic
  1027.                         Set dcWork.Font = mfntDayFont
  1028.                     End If
  1029.                 Else
  1030.                     mfntDayFont.Italic = (mafDayItalic(nDay) = calEffectOn)
  1031.                     Set dcWork.Font = mfntDayFont
  1032.                 End If
  1033.             End If 'we're in the current month day set
  1034.             
  1035.             'if it's the current day, draw it selected
  1036.             If nDay = mnDay And eDaySet = CurMonthDays Then
  1037.                 dcWork.Draw3DRect mrcCalArea.Left + (nCol * mcxColWidth), _
  1038.                                     mrcCalArea.Top + (nRow * mcyRowHeight), _
  1039.                                     mcxColWidth, mcyRowHeight, CStr(nDay), _
  1040.                                     caCenterCenter, Selected
  1041.                                     
  1042.             Else
  1043.             
  1044.                 dcWork.Draw3DRect mrcCalArea.Left + (nCol * mcxColWidth), _
  1045.                                     mrcCalArea.Top + (nRow * mcyRowHeight), _
  1046.                                     mcxColWidth, mcyRowHeight, CStr(nDay)
  1047.             
  1048.             End If 'current day
  1049.             
  1050.             'increment the day number
  1051.             nDay = nDay + 1
  1052.             
  1053.         Next nCol
  1054.     Next nRow
  1055.     
  1056.     'blast the control to the screen
  1057.     dcWork.BlastToScreen
  1058.     
  1059.     'if the dummy control has focus, and we are in run-mode,
  1060.     'draw a focus rect around the current focus area
  1061.     If UserControl.ActiveControl Is ctlFocus Then
  1062.         DrawFocusRect UserControl.hdc, mrcFocusArea
  1063.     End If
  1064.     
  1065.     'restore the initial settings for bold and italic
  1066.     'in our day font
  1067.     mfntDayFont.Bold = fDefBold
  1068.     mfntDayFont.Italic = fDefItalic
  1069.     
  1070.     Exit Sub
  1071.     
  1072. Err_Paint:
  1073.     Debug.Assert False
  1074.     Exit Sub
  1075. End Sub 'UserControl_Paint()
  1076.  
  1077. '----------------------------------------------------------------------
  1078. ' Resize Event
  1079. '----------------------------------------------------------------------
  1080. ' Purpose:  Called when the control is resized by the developer
  1081. ' Inputs:   None
  1082. ' Outputs:  None
  1083. '----------------------------------------------------------------------
  1084. Private Sub UserControl_Resize()
  1085.     Dim nNewWidth As Long       'new scale width
  1086.     Dim nNewHeight As Long      'new scale height
  1087.     Dim nUsableWidth As Long    'actual width we can use
  1088.     
  1089.     On Error GoTo Err_Resize
  1090.     
  1091.     nNewWidth = UserControl.ScaleWidth
  1092.     nNewHeight = UserControl.ScaleHeight
  1093.     
  1094.     'since all the grid cells need to be the same width
  1095.     'the usable width is the width we will consume and there
  1096.     'maybe unused pixels due to left-overs from division
  1097.     nUsableWidth = ((nNewWidth - (2 * mrcCalArea.Left)) \ NUMCOLS) * NUMCOLS
  1098.     
  1099.     'recalculate the bounding rectangles for the various areas
  1100.     'of the control (navigation, day names, and calendar days)
  1101.     mrcNavArea.Right = mrcNavArea.Left + nUsableWidth
  1102.     mrcDayNameArea.Right = mrcDayNameArea.Left + nUsableWidth
  1103.     mrcCalArea.Right = mrcCalArea.Left + nUsableWidth
  1104.     mrcCalArea.Bottom = nNewHeight
  1105.     
  1106.     'Recalculate the width and heights of the grid rows and columns
  1107.     mcxColWidth = (nNewWidth - (2 * mrcCalArea.Left)) \ NUMCOLS
  1108.     mcyRowHeight = (mrcCalArea.Bottom - mrcCalArea.Top) \ NUMROWS
  1109.     
  1110.     'resize the month and year selection controls
  1111.     btnNext.Left = mrcNavArea.Right - btnNext.Width
  1112.     
  1113.     'if there's not enough room, just display the buttons
  1114.     If (mrcNavArea.Right - mrcNavArea.Left) <= _
  1115.         (btnNext.Width + btnPrev.Width + txtYear.Width + 10) _
  1116.         And mfShowIterrators Then
  1117.         
  1118.         cbxMonth.Visible = False
  1119.         txtYear.Visible = False
  1120.         
  1121.     Else
  1122.     
  1123.         If Not mfMonthReadOnly Then cbxMonth.Visible = True
  1124.         If Not mfYearReadOnly Then txtYear.Visible = True
  1125.         
  1126.         If mfShowIterrators Then
  1127.             cbxMonth.Left = mrcNavArea.Left + btnPrev.Width + BORDER3D
  1128.             txtYear.Left = btnNext.Left - txtYear.Width - BORDER3D
  1129.         Else
  1130.             cbxMonth.Left = mrcNavArea.Left + BORDER3D
  1131.             txtYear.Left = mrcNavArea.Right - txtYear.Width - BORDER3D
  1132.         End If
  1133.         
  1134.         cbxMonth.Width = txtYear.Left - cbxMonth.Left
  1135.     
  1136.     End If 'not enough horizontal room
  1137.     
  1138.     Exit Sub
  1139.     
  1140. Err_Resize:
  1141.     Debug.Assert False
  1142.     Exit Sub
  1143.     
  1144. End Sub 'UserControl_Resize()
  1145.  
  1146. '----------------------------------------------------------------------
  1147. ' MouseDown Event
  1148. '----------------------------------------------------------------------
  1149. ' Purpose:  Called when the mouse button is pushed down while over
  1150. '           the control's area
  1151. ' Inputs:   Which mouse button, shift state and x and y position
  1152. ' Outputs:  None
  1153. '----------------------------------------------------------------------
  1154. Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  1155.     Dim Area As CalendarAreas
  1156.     Dim dtOld As Date
  1157.     Dim dtNew As Date
  1158.         
  1159.     On Error GoTo Err_MouseDown
  1160.     
  1161.     'keep the old date to see if it's changed
  1162.     dtOld = Me.Value
  1163.     
  1164.     'Do a hit test to determine where the user clicked
  1165.     Me.HitTest X, Y, Area, dtNew
  1166.     
  1167.     'if the area was in the date area and the control is not locked,
  1168.     'switch to the hit date
  1169.     If (Area = calDateArea) And (Not mfLocked) Then
  1170.         If dtNew <> dtOld Then
  1171.             ChangeValue VBA.Day(dtNew), VBA.Month(dtNew), VBA.Year(dtNew)
  1172.         End If 'date did change
  1173.     End If 'clicked in date area
  1174.     
  1175.     'grab focus back if needed
  1176.     If Not (UserControl.ActiveControl Is ctlFocus) Then
  1177.         ctlFocus.SetFocus
  1178.     End If
  1179.     
  1180.     Exit Sub
  1181.  
  1182. Err_MouseDown:
  1183.     Debug.Assert False
  1184.     Exit Sub
  1185. End Sub 'UserControl_MouseDown()
  1186.  
  1187. '----------------------------------------------------------------------
  1188. ' DblClick Event
  1189. '----------------------------------------------------------------------
  1190. ' Purpose:  Called when the user double-clicks on the main control area
  1191. ' Inputs:   None
  1192. ' Outputs:  None
  1193. '----------------------------------------------------------------------
  1194. Private Sub UserControl_DblClick()
  1195.     On Error GoTo Err_DblClick
  1196.     
  1197.     'pass this event to the host
  1198.     RaiseEvent DblClick
  1199.     Exit Sub
  1200.  
  1201. Err_DblClick:
  1202.     Exit Sub
  1203. End Sub 'UserControl_DblClick()
  1204.  
  1205. '----------------------------------------------------------------------
  1206. ' Click Event
  1207. '----------------------------------------------------------------------
  1208. ' Purpose:  Called when the user clicks on the main control area
  1209. ' Inputs:   None
  1210. ' Outputs:  None
  1211. '----------------------------------------------------------------------
  1212. Private Sub UserControl_Click()
  1213.     On Error GoTo Err_Click
  1214.     
  1215.     'raise our click event to the user
  1216.     RaiseEvent Click
  1217.  
  1218.     Exit Sub
  1219.     
  1220. Err_Click:
  1221.     Exit Sub
  1222. End Sub 'UserControl_Click()
  1223.  
  1224. '----------------------------------------------------------------------
  1225. ' ctlFocus_GotFocus Event
  1226. '----------------------------------------------------------------------
  1227. ' Purpose:  Called when the main calendar area is to get focus.
  1228. '           We use a dummy control to capture focus since we are
  1229. '           just painting the calendar days and cannot set focus
  1230. '           to the entire user control.
  1231. ' Inputs:   None
  1232. ' Outputs:  None
  1233. '----------------------------------------------------------------------
  1234. Private Sub ctlFocus_GotFocus()
  1235.     'draw a focus rect to signify that the calendar
  1236.     'area now has focus
  1237.     DrawFocusRect UserControl.hdc, mrcFocusArea
  1238. End Sub 'ctlFocus_GotFocus()
  1239.  
  1240. '----------------------------------------------------------------------
  1241. ' ctlFocus_LostFocus Event
  1242. '----------------------------------------------------------------------
  1243. ' Purpose:  Called when the main calendar area has lost focus.
  1244. '           We use a dummy control to capture focus since we are
  1245. '           just painting the calendar days and cannot set focus
  1246. '           to the entire user control.
  1247. ' Inputs:   None
  1248. ' Outputs:  None
  1249. '----------------------------------------------------------------------
  1250. Private Sub ctlFocus_LostFocus()
  1251.     'draw a focus rect where the last focus area was
  1252.     'drawing a focus rect twice removes it
  1253.     DrawFocusRect UserControl.hdc, mrcFocusArea
  1254. End Sub 'ctlFocus_LostFocus()
  1255.  
  1256. '----------------------------------------------------------------------
  1257. ' ctlFocus_KeyDown Event
  1258. '----------------------------------------------------------------------
  1259. ' Purpose:  Called when the user presses a key while the dummy control
  1260. '           has focus
  1261. ' Inputs:   Which key, shift state
  1262. ' Outputs:  None
  1263. '----------------------------------------------------------------------
  1264. Private Sub ctlFocus_KeyDown(KeyCode As Integer, Shift As Integer)
  1265.     Dim dtTemp As Date      'temp date for date arithmetic
  1266.     
  1267.     Select Case KeyCode
  1268.         Case vbKeyLeft
  1269.             dtTemp = DateSerial(mnYear, mnMonth, mnDay)
  1270.             
  1271.             'if shift is down, move by month
  1272.             If (Shift And vbShiftMask) > 0 Then
  1273.                 dtTemp = DateAdd("m", -1, dtTemp)
  1274.             
  1275.             ElseIf (Shift And vbCtrlMask) > 0 Then
  1276.                 'else if control is down, move by year
  1277.                 dtTemp = DateAdd("yyyy", -1, dtTemp)
  1278.             
  1279.             Else
  1280.                 'go back on day
  1281.                 dtTemp = DateAdd("d", -1, dtTemp)
  1282.             End If
  1283.             
  1284.             ChangeValue VBA.Day(dtTemp), VBA.Month(dtTemp), _
  1285.                         VBA.Year(dtTemp)
  1286.         
  1287.         Case vbKeyRight
  1288.             dtTemp = DateSerial(mnYear, mnMonth, mnDay)
  1289.             
  1290.             If (Shift And vbShiftMask) > 0 Then
  1291.                 dtTemp = DateAdd("m", 1, dtTemp)
  1292.             
  1293.             ElseIf (Shift And vbCtrlMask) > 0 Then
  1294.                 'else if control is down, move by year
  1295.                 dtTemp = DateAdd("yyyy", 1, dtTemp)
  1296.             
  1297.             Else
  1298.                 'go forward one day
  1299.                 dtTemp = DateAdd("d", 1, dtTemp)
  1300.             End If
  1301.             
  1302.             ChangeValue VBA.Day(dtTemp), VBA.Month(dtTemp), _
  1303.                         VBA.Year(dtTemp)
  1304.             
  1305.         Case vbKeyUp
  1306.             'go one week back
  1307.             dtTemp = DateSerial(mnYear, mnMonth, mnDay)
  1308.             dtTemp = DateAdd("ww", -1, dtTemp)
  1309.             ChangeValue VBA.Day(dtTemp), VBA.Month(dtTemp), _
  1310.                         VBA.Year(dtTemp)
  1311.             
  1312.         Case vbKeyDown
  1313.             'go one week forwad
  1314.             dtTemp = DateSerial(mnYear, mnMonth, mnDay)
  1315.             dtTemp = DateAdd("ww", 1, dtTemp)
  1316.             ChangeValue VBA.Day(dtTemp), VBA.Month(dtTemp), _
  1317.                         VBA.Year(dtTemp)
  1318.             
  1319.         Case vbKeyHome
  1320.             'if control is down, go to first day of the year
  1321.             If (Shift And vbCtrlMask) > 0 Then
  1322.                 ChangeValue 1, 1, mnYear
  1323.             Else
  1324.                 'go to the first day of the current month
  1325.                 ChangeValue 1, mnMonth, mnYear
  1326.             End If
  1327.             
  1328.         Case vbKeyEnd
  1329.             'if control is down, go to last day of the year
  1330.             If (Shift And vbCtrlMask) > 0 Then
  1331.                 ChangeValue 31, 12, mnYear
  1332.             Else
  1333.                 'go to the last day of the current month
  1334.                 ChangeValue MaxDayInMonth(mnMonth, mnYear), _
  1335.                             mnMonth, mnYear
  1336.             End If
  1337.             
  1338.     End Select
  1339. End Sub 'ctlFocus_KeyDown()
  1340.  
  1341. '----------------------------------------------------------------------
  1342. ' cbxMonth_Click Event
  1343. '----------------------------------------------------------------------
  1344. ' Purpose:  Called when the user changes the item selected in the moth
  1345. '           navigation combo box
  1346. ' Inputs:   none
  1347. ' Outputs:  None
  1348. '----------------------------------------------------------------------
  1349. Private Sub cbxMonth_Click()
  1350.     If mfIgnoreMonthYearChange Then Exit Sub
  1351.     
  1352.     'if we are locked, just reset the list index
  1353.     'to the current month
  1354.     If mfLocked Then
  1355.         mfIgnoreMonthYearChange = True
  1356.         cbxMonth.ListIndex = mnMonth - 1
  1357.         mfIgnoreMonthYearChange = False
  1358.     End If
  1359.     
  1360.     'change the date
  1361.     ChangeValue mnDay, cbxMonth.ListIndex + 1, mnYear
  1362.     
  1363.     RaiseEvent Click
  1364. End Sub 'cbxMonth_Click()
  1365.  
  1366. '----------------------------------------------------------------------
  1367. ' txtYear_KeyPress Event
  1368. '----------------------------------------------------------------------
  1369. ' Purpose:  Called when the user presses a key in the year
  1370. '           navigation text box
  1371. ' Inputs:   Key Pressed
  1372. ' Outputs:  None
  1373. '----------------------------------------------------------------------
  1374. Private Sub txtYear_KeyPress(KeyAscii As Integer)
  1375.     If mfIgnoreMonthYearChange Then Exit Sub
  1376.     
  1377.     'if they pressed return, process the date change
  1378.     If KeyAscii = vbKeyReturn Then
  1379.         'change the date
  1380.         ChangeValue mnDay, mnMonth, Val(txtYear)
  1381.         KeyAscii = 0
  1382.     End If
  1383.     
  1384. End Sub 'txtYear_KeyPress
  1385.  
  1386. '----------------------------------------------------------------------
  1387. ' txtYear_Click Event
  1388. '----------------------------------------------------------------------
  1389. ' Purpose:  Called when the user clicks the year
  1390. '           navigation text box
  1391. ' Inputs:   None
  1392. ' Outputs:  None
  1393. '----------------------------------------------------------------------
  1394. Private Sub txtYear_Click()
  1395.     RaiseEvent Click
  1396. End Sub 'txtYear_Click()
  1397.  
  1398. '----------------------------------------------------------------------
  1399. ' txtYear_GotFocus Event
  1400. '----------------------------------------------------------------------
  1401. ' Purpose:  Called when the user moved into the year text box
  1402. ' Inputs:   None
  1403. ' Outputs:  None
  1404. '----------------------------------------------------------------------
  1405. Private Sub txtYear_GotFocus()
  1406.     'select all the text that is there
  1407.     txtYear.SelStart = 0
  1408.     txtYear.SelLength = Len(txtYear.Text)
  1409. End Sub
  1410.  
  1411. '----------------------------------------------------------------------
  1412. ' txtYear_LostFocus Event
  1413. '----------------------------------------------------------------------
  1414. ' Purpose:  Called when the user moved out of the year text box
  1415. ' Inputs:   None
  1416. ' Outputs:  None
  1417. '----------------------------------------------------------------------
  1418. Private Sub txtYear_LostFocus()
  1419.     If mnYear <> Val(txtYear.Text) Then
  1420.         ChangeValue mnDay, mnMonth, Val(txtYear.Text)
  1421.     End If
  1422. End Sub 'txtYear_LostFocus()
  1423.  
  1424.  
  1425. '----------------------------------------------------------------------
  1426. ' btnNext_Click Event
  1427. '----------------------------------------------------------------------
  1428. ' Purpose:  Called when the user clicks the next month button
  1429. ' Inputs:   none
  1430. ' Outputs:  None
  1431. '----------------------------------------------------------------------
  1432. Private Sub btnNext_Click()
  1433.     Dim dtTemp As Date
  1434.     dtTemp = DateSerial(mnYear, mnMonth, mnDay)
  1435.     dtTemp = DateAdd("m", 1, dtTemp)
  1436.     ChangeValue VBA.Day(dtTemp), VBA.Month(dtTemp), VBA.Year(dtTemp)
  1437.     ctlFocus.SetFocus
  1438.     RaiseEvent Click
  1439. End Sub 'btnNext_Click()
  1440.  
  1441. '----------------------------------------------------------------------
  1442. ' btnPrev_Click Event
  1443. '----------------------------------------------------------------------
  1444. ' Purpose:  Called when the user clicks the previous month button
  1445. ' Inputs:   none
  1446. ' Outputs:  None
  1447. '----------------------------------------------------------------------
  1448. Private Sub btnPrev_Click()
  1449.     Dim dtTemp As Date
  1450.     dtTemp = DateSerial(mnYear, mnMonth, mnDay)
  1451.     dtTemp = DateAdd("m", -1, dtTemp)
  1452.     ChangeValue VBA.Day(dtTemp), VBA.Month(dtTemp), VBA.Year(dtTemp)
  1453.     ctlFocus.SetFocus
  1454.     RaiseEvent Click
  1455. End Sub 'btnPrev_Click()
  1456.  
  1457.  
  1458. '======================================================================
  1459. ' Private Helper Methods
  1460. '======================================================================
  1461.  
  1462. '----------------------------------------------------------------------
  1463. ' PaintDayNames()
  1464. '----------------------------------------------------------------------
  1465. ' Purpose:  Paints names of the week days above the main date grid
  1466. ' Inputs:   reference to the offscreen dc object
  1467. ' Outputs:  none
  1468. '----------------------------------------------------------------------
  1469. Private Sub PaintDayNames(dc As OffScreenDC)
  1470.     Dim rc As RECT
  1471.     Dim nCol As Long
  1472.     Dim fntOld As StdFont
  1473.     Dim idx As Long
  1474.     
  1475.     'make a copy of the day name area rect
  1476.     rc.Left = mrcDayNameArea.Left
  1477.     rc.Top = mrcDayNameArea.Top
  1478.     rc.Right = mrcDayNameArea.Right
  1479.     rc.Bottom = mrcDayNameArea.Bottom
  1480.     
  1481.     'set the current font to use
  1482.     Set fntOld = dc.Font
  1483.     Set dc.Font = mfntDayNames
  1484.     
  1485.     'fill a black rect as a border
  1486.     dc.FillRect rc.Left, rc.Top, rc.Right - rc.Left, _
  1487.                 rc.Bottom - rc.Top, vbBlack
  1488.                 
  1489.     'now draw 3d rects for each day name
  1490.     rc.Top = rc.Top + 1
  1491.     rc.Bottom = rc.Bottom - 1
  1492.     
  1493.     'initialize idx to be the setting for first day of week
  1494.     'and if that setting is "use system", determine what the
  1495.     'system is using
  1496.     If mnFirstDayOfWeek = vbUseSystemDayOfWeek Then
  1497.         '8/4/96 is a Sunday, so if the system says the day
  1498.         'of week is other than 1, we'll figure that out
  1499.         idx = WeekDay(DateSerial(1996, 8, 4), mnFirstDayOfWeek)
  1500.     Else
  1501.         idx = mnFirstDayOfWeek
  1502.     End If 'first day of week was "use system"
  1503.     
  1504.     For nCol = 0 To NUMCOLS - 1
  1505.         dc.Draw3DRect (nCol * mcxColWidth) + rc.Left, rc.Top, mcxColWidth, _
  1506.                         rc.Bottom - rc.Top, masDayNames(idx - 1)
  1507.         
  1508.         'increment the indexer and if it's past the end
  1509.         'wrap it back around to zero
  1510.         idx = idx + 1
  1511.         If idx > NUMCOLS Then idx = 1
  1512.     Next nCol
  1513.     
  1514.     'reset the old font
  1515.     Set dc.Font = fntOld
  1516. End Sub 'PaintDayNames()
  1517.  
  1518. '----------------------------------------------------------------------
  1519. ' FastRepaint()
  1520. '----------------------------------------------------------------------
  1521. ' Purpose:  Fast repaint routine for painting when only the day number
  1522. '           changes and not the month or year.
  1523. ' Inputs:   work off screen DC
  1524. ' Outputs:  none
  1525. '----------------------------------------------------------------------
  1526. Private Sub FastRepaint(dcWork As OffScreenDC)
  1527.     Dim nLeft As Long
  1528.     Dim nTop As Long
  1529.     Dim rgbColor As Long
  1530.     Dim ct As Long
  1531.     Dim eAppearance As Appearances
  1532.     Dim fDefBold As Boolean
  1533.     Dim fDefItalic As Boolean
  1534.     
  1535.     'save the initial states of bold and italic in our day font
  1536.     fDefBold = mfntDayFont.Bold
  1537.     fDefItalic = mfntDayFont.Italic
  1538.     
  1539.     'set the font as the day font and the text
  1540.     'color as black
  1541.     Set dcWork.Font = mfntDayFont
  1542.     OleTranslateColor mclrDay, 0, rgbColor
  1543.     dcWork.TextColor = rgbColor
  1544.     
  1545.     For ct = 0 To 1
  1546.         If mafDayBold(maRepaintDays(ct)) = calEffectDefault Then
  1547.             'optimize for the case where no days are bold
  1548.             If mfntDayFont.Bold <> fDefBold Then
  1549.                 mfntDayFont.Bold = fDefBold
  1550.                 Set dcWork.Font = mfntDayFont
  1551.             End If
  1552.         Else
  1553.             mfntDayFont.Bold = (mafDayBold(maRepaintDays(ct)) = calEffectOn)
  1554.             Set dcWork.Font = mfntDayFont
  1555.         End If 'DayBold setting is default
  1556.         
  1557.         If mafDayItalic(maRepaintDays(ct)) = calEffectDefault Then
  1558.             'optimize for the case where no days are italic
  1559.             If mfntDayFont.Italic <> fDefItalic Then
  1560.                 mfntDayFont.Italic = fDefItalic
  1561.                 Set dcWork.Font = mfntDayFont
  1562.             End If
  1563.         Else
  1564.             mfntDayFont.Italic = (mafDayItalic(maRepaintDays(ct)) = calEffectOn)
  1565.             Set dcWork.Font = mfntDayFont
  1566.         End If
  1567.         
  1568.         'repaint the old day as normal
  1569.         nLeft = LeftForDay(maRepaintDays(ct))
  1570.         nTop = TopForDay(maRepaintDays(ct))
  1571.         
  1572.         If ct = 0 Then
  1573.             eAppearance = Raised
  1574.         Else
  1575.             eAppearance = Selected
  1576.         End If
  1577.         
  1578.         dcWork.Draw3DRect nLeft, nTop, _
  1579.                             mcxColWidth, mcyRowHeight, _
  1580.                             CStr(maRepaintDays(ct)), _
  1581.                             caCenterCenter, eAppearance
  1582.         
  1583.         'blast just this day to the screen
  1584.         dcWork.BlastToScreen nLeft, nTop, mcxColWidth, mcyRowHeight
  1585.     
  1586.     Next ct
  1587.     
  1588. '    'repaint the newly selected day as selected
  1589. '    nLeft = LeftForDay(maRepaintDays(1))
  1590. '    nTop = TopForDay(maRepaintDays(1))
  1591. '    dcWork.Draw3DRect nLeft, nTop, _
  1592. '                        mcxColWidth, mcyRowHeight, _
  1593. '                        CStr(maRepaintDays(1)), _
  1594. '                        caCenterCenter, Selected
  1595. '
  1596. '    'blast just this day to the screen
  1597. '    dcWork.BlastToScreen nLeft, nTop, mcxColWidth, mcyRowHeight
  1598.     
  1599.     'draw the focus rect on the selected day if
  1600.     'the dummy focus control has focus
  1601.     If UserControl.ActiveControl Is ctlFocus Then
  1602.         DrawFocusRect UserControl.hdc, mrcFocusArea
  1603.     End If
  1604.     
  1605.     'restore the initial states of bold and italic in our day font
  1606.     mfntDayFont.Bold = fDefBold
  1607.     mfntDayFont.Italic = fDefItalic
  1608.     
  1609.     'reset the fast repaint flag to False
  1610.     mfFastRepaint = False
  1611.     
  1612. End Sub 'FastRepaint()
  1613.  
  1614. '----------------------------------------------------------------------
  1615. ' MaxDayInMonth()
  1616. '----------------------------------------------------------------------
  1617. ' Purpose:  Returns the max day number for a given month number and year
  1618. ' Inputs:   month number
  1619. ' Outputs:  max day number
  1620. '----------------------------------------------------------------------
  1621. Private Function MaxDayInMonth(nMonth As Long, Optional nYear As Long = 0) As Long
  1622.     Select Case nMonth
  1623.         Case 9, 4, 6, 11    '30 days hath September,
  1624.                             'April, June, and November
  1625.             MaxDayInMonth = 30
  1626.         
  1627.         Case 2              'February -- check for leapyear
  1628.             'The full rule for leap years is that they occur in
  1629.             'every year divisible by four, except that they don't
  1630.             'occur in years divisible by 100, except that they
  1631.             '*do* in years divisible by 400.
  1632.             If (nYear Mod 4) = 0 Then
  1633.                 If nYear Mod 100 = 0 Then
  1634.                     If nYear Mod 400 = 0 Then
  1635.                         MaxDayInMonth = 29
  1636.                     Else
  1637.                         MaxDayInMonth = 28
  1638.                     End If 'divisible by 400
  1639.                 Else
  1640.                     MaxDayInMonth = 29
  1641.                 End If 'divisible by 100
  1642.             Else
  1643.                 MaxDayInMonth = 28
  1644.             End If 'divisible by 4
  1645.         
  1646.         Case Else           'All the rest have 31
  1647.             MaxDayInMonth = 31
  1648.     
  1649.     End Select
  1650. End Function 'MaxDayInMonth()
  1651.  
  1652. '----------------------------------------------------------------------
  1653. ' ChangeValue()
  1654. '----------------------------------------------------------------------
  1655. ' Purpose:  Changes the control's current value, checking if it's OK
  1656. '           and doing the necessary notifications that it's changed
  1657. ' Inputs:   new day, month and year
  1658. ' Outputs:  none
  1659. '----------------------------------------------------------------------
  1660. Private Sub ChangeValue(nDay As Long, nMonth As Long, nYear As Long)
  1661.     Dim rc As RECT          'used to invalidate smaller rects
  1662.                             'if only the day number changed
  1663.     
  1664.     Dim fCancel As Boolean  'used in the WillChangeDate event
  1665.     Dim dtOld As Date       'old date for raising in event
  1666.     
  1667.     'give the developer a chance to cancel the date change
  1668.     fCancel = False
  1669.     RaiseEvent WillChangeDate(DateSerial(nYear, nMonth, nDay), fCancel)
  1670.     If fCancel Then Exit Sub
  1671.     
  1672.     'build a date using the current values
  1673.     dtOld = DateSerial(mnYear, mnMonth, mnDay)
  1674.     
  1675.     'check to see if it's OK to change the value
  1676.     If UserControl.CanPropertyChange("Value") Then
  1677.         
  1678.         'changing the month or year can make the day number
  1679.         'invalid, so check the new combination and adjust the day
  1680.         'if necessary.
  1681.         If nDay > MaxDayInMonth(nMonth, nYear) Then
  1682.             nDay = MaxDayInMonth(nMonth, nYear)
  1683.         End If
  1684.         
  1685.         'to avoid unecessary repainting, if only the day number changed
  1686.         'just invalidate the two rects where the old and new dates are
  1687.         If mnMonth = nMonth And mnYear = nYear Then
  1688.             
  1689.             'setup a rect for the old day
  1690.             rc.Left = LeftForDay(mnDay)
  1691.             rc.Top = TopForDay(mnDay)
  1692.             rc.Right = rc.Left + mcxColWidth
  1693.             rc.Bottom = rc.Top + mcyRowHeight
  1694.             
  1695.             'invalidate it
  1696.             InvalidateRect UserControl.hwnd, rc, 0
  1697.             
  1698.             'setup a rect for the new day
  1699.             rc.Left = LeftForDay(nDay)
  1700.             rc.Top = TopForDay(nDay)
  1701.             rc.Right = rc.Left + mcxColWidth
  1702.             rc.Bottom = rc.Top + mcyRowHeight
  1703.             
  1704.             'invalidate it
  1705.             InvalidateRect UserControl.hwnd, rc, 0
  1706.             
  1707.             'since we are only changing the current day
  1708.             'and not the current month or year, store off
  1709.             'the specific days to repaint and set the
  1710.             'fast repaint flag to true.  This will cause the
  1711.             'paint routing to just repaint these two days
  1712.             'which makes the repaint considerably faster.
  1713.             'The fast repaint is reset to False automatically.
  1714.             maRepaintDays(0) = mnDay
  1715.             maRepaintDays(1) = nDay
  1716.             mfFastRepaint = True
  1717.             
  1718.             'change the value and notify those interested
  1719.             mnDay = nDay
  1720.             
  1721.         Else
  1722.             'reset the month and year navigators if they need to be
  1723.             mfIgnoreMonthYearChange = True
  1724.             If cbxMonth.ListIndex <> (nMonth - 1) Then cbxMonth.ListIndex = (nMonth - 1)
  1725.             If Val(txtYear.Text) <> nYear Then txtYear.Text = nYear
  1726.             mfIgnoreMonthYearChange = False
  1727.             
  1728.             'change the value and notify those interested
  1729.             mnDay = nDay
  1730.             mnMonth = nMonth
  1731.             mnYear = nYear
  1732.  
  1733.             'refresh the entire calendar area since we have to
  1734.             're-layout the days
  1735.             InvalidateRect UserControl.hwnd, mrcCalArea, 0
  1736.         End If 'just changing the day
  1737.         
  1738.         'update the new focus area based on the new day selected
  1739.         mrcFocusArea.Left = LeftForDay(mnDay) + FOCUSBORDER
  1740.         mrcFocusArea.Top = TopForDay(mnDay) + FOCUSBORDER
  1741.         mrcFocusArea.Right = mrcFocusArea.Left + mcxColWidth - (2 * FOCUSBORDER)
  1742.         mrcFocusArea.Bottom = mrcFocusArea.Top + mcyRowHeight - (2 * FOCUSBORDER)
  1743.     
  1744.         'update the window (usercontrol.refresh will invalidate
  1745.         'everything so call UpdateWindow directly)
  1746.         UpdateWindow UserControl.hwnd
  1747.     
  1748.         'notify of the date change
  1749.         UserControl.PropertyChanged "Value"
  1750.         RaiseEvent DateChange(dtOld, DateSerial(mnYear, mnMonth, mnDay))
  1751.         
  1752.     Else 'can't change prop
  1753.         mobjRes.RaiseUserError errCantChange, Array("Value")
  1754.         
  1755.     End If 'can change prop
  1756. End Sub 'ChangeValue()
  1757.  
  1758. '----------------------------------------------------------------------
  1759. ' LeftForDay()
  1760. '----------------------------------------------------------------------
  1761. ' Purpose:  Returns the left (X) coodinate for a given day in the
  1762. '           current month and year
  1763. ' Inputs:   day number
  1764. ' Outputs:  left coordinate
  1765. '----------------------------------------------------------------------
  1766. Private Function LeftForDay(nDay As Long) As Long
  1767.     'the left coordinate for a given day is a function of the
  1768.     'weekday (column number) of the day, the column width and
  1769.     'the grid's left border
  1770.     LeftForDay = ((WeekDay(DateSerial(mnYear, mnMonth, nDay), mnFirstDayOfWeek) - 1) _
  1771.                     * mcxColWidth) + mrcCalArea.Left
  1772. End Function 'LeftForDay()
  1773.  
  1774. '----------------------------------------------------------------------
  1775. ' TopForDay()
  1776. '----------------------------------------------------------------------
  1777. ' Purpose:  Returns the top (Y) coodinate for a given day in the
  1778. '           current month and year
  1779. ' Inputs:   day number
  1780. ' Outputs:  top coordinate
  1781. '----------------------------------------------------------------------
  1782. Private Function TopForDay(nDay As Long) As Long
  1783.     Dim nRow As Long
  1784.     
  1785.     'the top coordinate for a given day is a function of the
  1786.     'row number of the day (day + column number of first day of month
  1787.     'divided by number of columns), the row height, and the top of the
  1788.     'entire grid
  1789.     
  1790.     'we subtract 2 from the left side of the division since the
  1791.     'weekday function is 1-based and since we need to subtract an
  1792.     'additional one to make zero-base the day
  1793.     nRow = (nDay + WeekDay(DateSerial(mnYear, mnMonth, 1), mnFirstDayOfWeek) - 2) \ NUMCOLS
  1794.     
  1795.     TopForDay = (nRow * mcyRowHeight) + mrcCalArea.Top
  1796.     
  1797. End Function 'TopForDay()
  1798.  
  1799. '----------------------------------------------------------------------
  1800. ' DateForRowCol()
  1801. '----------------------------------------------------------------------
  1802. ' Purpose:  Returns the Date for a given row and column in the
  1803. '           current calendar grid
  1804. ' Inputs:   row and column number (zero-based)
  1805. ' Outputs:  corresponding date
  1806. '----------------------------------------------------------------------
  1807. Private Function DateForRowCol(nRow As Long, nCol As Long) As Date
  1808.     Dim dtFirstDay As Date
  1809.     Dim nColFirstDay As Long
  1810.     Dim ctDaysDiff As Long
  1811.     
  1812.     Debug.Assert (nRow < NUMROWS)
  1813.     Debug.Assert (nCol < NUMCOLS)
  1814.     
  1815.     'get the column for the first day of the current month
  1816.     'first day is always in row 1
  1817.     dtFirstDay = DateSerial(mnYear, mnMonth, 1)
  1818.     nColFirstDay = WeekDay(dtFirstDay, mnFirstDayOfWeek) - 1
  1819.     
  1820.     'how many days away is the current row and column?
  1821.     ctDaysDiff = (nCol - nColFirstDay) + (NUMDAYS * nRow)
  1822.     
  1823.     'calc the hit date by using date arithmetic
  1824.     DateForRowCol = DateAdd("d", ctDaysDiff, dtFirstDay)
  1825. End Function 'DateForRowCol()
  1826.  
  1827. '----------------------------------------------------------------------
  1828. ' GetPrevMonthDays()
  1829. '----------------------------------------------------------------------
  1830. ' Purpose:  Calculates the first and last day of the previous month
  1831. '           that should be displayed before the first day of the
  1832. '           of the given month and year
  1833. ' Inputs:   current month and year
  1834. ' Outputs:  first and last day of prev month to display
  1835. '----------------------------------------------------------------------
  1836. Private Sub GetPrevMonthDays(ByVal nCurMonth As Long, ByVal nCurYear As Long, nFirst As Long, nLast As Long)
  1837.     Dim dtTemp As Date          'temp date
  1838.     Dim nColDayOne As Long      'column of 1st day of cur month
  1839.     
  1840.     'construct a date to do date math
  1841.     dtTemp = DateSerial(nCurYear, nCurMonth, 1)
  1842.     
  1843.     'determine the column of the first day of the current month
  1844.     nColDayOne = WeekDay(dtTemp, mnFirstDayOfWeek)
  1845.     
  1846.     'if the first day of the current month is in column 1, we
  1847.     'don't need to paint any days from the prev month, so return
  1848.     'zeros and -1 for the first and last value
  1849.     If nColDayOne = 1 Then
  1850.         nFirst = 0
  1851.         nLast = -1
  1852.     Else
  1853.         'if there are days to paint, calculate the last and
  1854.         'first day using date math
  1855.         dtTemp = DateAdd("d", -1, dtTemp)
  1856.         nLast = VBA.Day(dtTemp)
  1857.         
  1858.         dtTemp = DateAdd("d", -(nColDayOne - 2), dtTemp)
  1859.         nFirst = VBA.Day(dtTemp)
  1860.     End If 'no days to paint
  1861.     
  1862. End Sub 'GetPrevMonthDays()
  1863.  
  1864. '----------------------------------------------------------------------
  1865. ' LoadMonthNames()
  1866. '----------------------------------------------------------------------
  1867. ' Purpose:  Loads the names of the months into the month selector
  1868. '           combo box
  1869. ' Inputs:   none
  1870. ' Outputs:  none
  1871. '----------------------------------------------------------------------
  1872. Private Sub LoadMonthNames()
  1873.     Dim nMonth As Long
  1874.     
  1875.     'use the format function to return the system specified
  1876.     'long month name for each month
  1877.     For nMonth = 1 To 12
  1878.         masMonthNames(nMonth - 1) = Format(DateSerial(100, nMonth, 1), "mmmm")
  1879.         cbxMonth.AddItem masMonthNames(nMonth - 1)
  1880.     Next nMonth
  1881. End Sub 'LoadMonthNames()
  1882.  
  1883. '----------------------------------------------------------------------
  1884. ' LoadDayNames()
  1885. '----------------------------------------------------------------------
  1886. ' Purpose:  Loads the names of the days into the day name string array
  1887. ' Inputs:   none
  1888. ' Outputs:  none
  1889. '----------------------------------------------------------------------
  1890. Private Sub LoadDayNames()
  1891.     Dim nDay As Long
  1892.     Dim sFormat As String
  1893.     
  1894.     Select Case mnDayNameFormat
  1895.         Case calShortName, calMediumName
  1896.             sFormat = "ddd"
  1897.         
  1898.         Case calLongName
  1899.             sFormat = "dddd"
  1900.     End Select
  1901.     
  1902.     For nDay = 1 To 7
  1903.         'if they want the short format, just take the first char
  1904.         If mnDayNameFormat = calShortName Then
  1905.             masDayNames(nDay - 1) = Left$(Format(DateSerial(1996, 8, 3 + nDay), sFormat), 1)
  1906.         Else
  1907.             masDayNames(nDay - 1) = Format(DateSerial(1996, 8, 3 + nDay), sFormat)
  1908.         End If
  1909.     Next nDay
  1910. End Sub 'LoadDayNames()
  1911.  
  1912. '----------------------------------------------------------------------
  1913. ' CopyFont
  1914. '----------------------------------------------------------------------
  1915. ' Purpose:  Copies the contents of one StdFont object to another
  1916. ' Inputs:   source and destination StdFont object
  1917. ' Outputs:  none
  1918. '----------------------------------------------------------------------
  1919. Private Sub CopyFont(fntSource As StdFont, fntDest As StdFont)
  1920.     'daveste -- 8/14/96
  1921.     'REVIEW:  Is there a better way to do this???!!!
  1922.     
  1923.     'if the destination is nothing, create a new font object
  1924.     If fntDest Is Nothing Then Set fntDest = New StdFont
  1925.     
  1926.     fntDest.Bold = fntSource.Bold
  1927.     fntDest.Charset = fntSource.Charset
  1928.     fntDest.Italic = fntSource.Italic
  1929.     fntDest.Name = fntSource.Name
  1930.     fntDest.Size = fntSource.Size
  1931.     fntDest.Strikethrough = fntSource.Strikethrough
  1932.     fntDest.Underline = fntSource.Underline
  1933.     fntDest.Weight = fntSource.Weight
  1934. End Sub 'CopyFont()
  1935.  
  1936.  
  1937.