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