1 Option Explicit
2
3
4 ''' // **********************************************************************************
5 ''' // Date Picker Class
6 ''' // **********************************************************************************
7
8 'DEVELOPED AND TESTED UNDER MICROSOFT ACCESS 97 VBA
9 ' There is a seperate A2K or higher version required because
10 ' A97 does not support AddressOf.
11 ' That is the only difference between the A97 and the A2K versions.
12 '
13 'Copyright: Stephen Lebans - Lebans Holdings 1999 Ltd.
14 ' Pedro Gil
15 ' Please feel free to use this code within your own
16 ' projects whether they are private or commercial applications
17 ' without obligation.
18 ' This code may not be resold by itself or as part of a collection.
19 '
20 'Name: clsMonthCal
21 '
22 'Version: 2.05
23 '
24 'Purpose:
25 ' To allow for the selection of a Date or Dates using the standard
26 ' Windows Month Calendar control without having to use the ActiveX control.
27 '
28 'Authors: Stephen Lebans
29 ' Pedro Gil
30
31 'Email: Stephen@lebans.com
32 ' pmpg98@hotmail.com
33 '
34 'Web Site: www.lebans.com
35 '
36 'Date: December 09, 2004
37 '
38 'Credits: Pedro Gil for doing the background
39 ' research necessary to code a working model.
40 ' Stephen Lebans for the API non ActiveX solution,
41 ' with autosizing, user selectable display.
42 ' Michael Kaplan for the idea to create the
43 ' Month Calendar directly from the Common Control DLL.
44 ' jwolzvb@yahoo.de for a VB example of implementing
45 ' a 1 month ActiveX MonthCalendar control.
46 '
47 'BUGS: Please report any bugs to Stephen@Lebans.com
48 '
49 'What's Missing:
50 ' Proper error handling.
51 '
52 'How it Works:
53 ' The Month Calendar is created directly with the
54 ' API's contained in the Common Controls DLL. In this manner we bypass
55 ' the DatePicker ActiveX control, which is simply a wrapper for these
56 ' calls anyway. This removes any problems from distribution and
57 ' especially version issues of using the ActiveX control.
58
59 ' DAYSTATE:
60 ' Have a look at the Initialize sub for this Class to see how to
61 ' set the DayStates for the months. You can also set the bits
62 ' in the array yourself if you are converting data that you
63 ' are storing in your own tables.
64 '
65 ' This is the ?th release. We have exposed most of the properties of the
66 ' Month Calendar. Simply add your own for any we have left out.
67
68 ''' // **********************************************************************************
69 ''' // Ver.: 3.0.0
70 ''' // (c) 2009; digital-ecom GmbH
71 ''' // Adapted to MS Excel incl. Excel 2000
72
73 ''' // Extension:
74 ''' // Allow setting a restricted date range a user can use, i.e. no dates smaller 01.04.2007 and/or no dates greater 01.04.2010.
75 ''' // digital-ecom GmbH, 22.05.2009
76
77 ''' // Bug Fixing:
78 ''' // When closing the dialog, especially on cancel:
79 ''' // First activate Excel Window, then close Calendar Ctrl - this assures we do not jump to other applications when simply closing
80 ''' // the calendar Ctrl and it does prevent screen flickering.
81 ''' // digital-ecom GmbH, 08.05.2009
82
83 ''' // Made the control capable to be used with modeless user forms.
84 ''' // digital-ecom GmbH, May 2009
85
86 ''' // Made code readable ... <sigh />
87 ''' // Added usage of just one constant for Classname and Title
88
89 ''' // Note: All original comments were used where possible. Our comments are introduced by ''' // always.
90 ''' // **********************************************************************************
91
92 Private Type RECT
93 Left As Long
94 Top As Long
95 Right As Long
96 Bottom As Long
97 End Type
98
99 Private Type POINTAPI
100 X As Long
101 y As Long
102 End Type
103
104
105 'Window Style Bits
106 Private Const WS_OVERLAPPED = &H0&
107 Private Const WS_POPUP = &H80000000
108 Private Const WS_CHILD = &H40000000
109 Private Const WS_MINIMIZE = &H20000000
110 Private Const WS_VISIBLE = &H10000000
111 Private Const WS_DISABLED = &H8000000
112 Private Const WS_CLIPSIBLINGS = &H4000000
113 Private Const WS_CLIPCHILDREN = &H2000000
114 Private Const WS_MAXIMIZE = &H1000000
115 Private Const WS_CAPTION = &HC00000
116 Private Const WS_BORDER = &H800000
117 Private Const WS_DLGFRAME = &H400000
118 Private Const WS_VSCROLL = &H200000
119 Private Const WS_HSCROLL = &H100000
120 Private Const WS_SYSMENU = &H80000
121 Private Const WS_THICKFRAME = &H40000
122
123 ' SetWindowPos Flags
124 Private Const SWP_NOSIZE = &H1
125
126
127 'Windows Style Bits Specific to DTP
128 Private Const DTS_UPDOWN As Long = &H1 '0x0001 // use UPDOWN instead of MONTHCAL
129 Private Const DTS_SHOWNONE As Long = &H2 '0x0002 // allow a NONE selection
130 Private Const DTS_SHORTDATEFORMAT As Long = &H0 '0x0000 // use the short date format (app must forward WM_WININICHANGE messages)
131 Private Const DTS_LONGDATEFORMAT As Long = &H4 '0x0004 // use the long date format (app must forward WM_WININICHANGE messages)
132 Private Const DTS_TIMEFORMAT As Long = &H9 '0x0009 // use the time format (app must forward WM_WININICHANGE messages)
133 Private Const DTS_APPCANPARSE As Long = &H10 '0x0010 // allow user entered strings (app MUST respond to DTN_USERSTRING)
134 Private Const DTS_RIGHTALIGN As Long = &H20 '0x0020 // right-align popup instead of left-align it
135
136 ' Used to change Font for Month Calendar common control
137 Private Const WM_SETFONT = &H30
138
139 '// bit-packed array of "bold" info for a month
140 '// if a bit is on, that day is drawn bold
141 Private Type MONTHDAYSTATE
142 lpMONTHDAYSTATE As Long
143 End Type
144
145 Private Type SYSTEMTIME
146 wYear As Integer
147 wMonth As Integer
148 wDayOfWeek As Integer
149 wDay As Integer
150 wHour As Integer
151 wMinute As Integer
152 wSecond As Integer
153 wMilliseconds As Integer
154 End Type
155
156 Private Type NMHDR
157 hwndFrom As Long
158 idfrom As Long
159 code As Long 'Integer
160 End Type
161
162 Private Type NMDAYSTATE
163 nmhd As NMHDR ' // this must be first, so we don't break WM_NOTIFY
164 stStart As SYSTEMTIME
165 cDayState As Long
166 prgDayState(11) As MONTHDAYSTATE ' For ease of use always specify 12 months of data - points to cDayState MONTHDAYSTATEs
167 End Type
168
169 Private Declare Function apiCreateWindowEx Lib "user32.dll" Alias "CreateWindowExA" _
170 (ByVal dwExStyle As Long, _
171 ByVal lpClassName As String, _
172 ByVal lpWindowName As String, _
173 ByVal dwStyle As Long, _
174 ByVal X As Long, _
175 ByVal y As Long, _
176 ByVal nWidth As Long, _
177 ByVal nHeight As Long, _
178 ByVal hWndParent As Long, _
179 ByVal hMenu As Long, _
180 ByVal hInstance As Long, _
181 lpParam As Any) As Long
182
183 Private Declare Function apiDestroyWindow Lib "user32" Alias "DestroyWindow" _
184 (ByVal hwnd As Long) As Long
185
186 Private Declare Function apiCreateFont Lib "gdi32" Alias "CreateFontA" _
187 (ByVal h As Long, ByVal w As Long, ByVal E As Long, ByVal O As Long, _
188 ByVal w As Long, ByVal i As Long, ByVal u As Long, ByVal s As Long, _
189 ByVal c As Long, ByVal OP As Long, ByVal CP As Long, ByVal Q As Long, _
190 ByVal PAF As Long, ByVal f As String) As Long
191
192 Private Declare Function apiMulDiv Lib "kernel32" Alias "MulDiv" _
193 (ByVal nNumber As Long, _
194 ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
195
196 'To register the class
197 Private Type INITCOMMONCONTROLSEXSTRUCT
198 dwsize As Long
199 dwICC As Long
200 End Type
201
202 Private Declare Function apiInitCommonControlsEx Lib "Comctl32" Alias "InitCommonControlsEx" _
203 (lpInitCtrls As INITCOMMONCONTROLSEXSTRUCT) As Long
204
205 Private Const ICC_DATE_CLASSES = &H100
206
207 'Get Instance of Access by KEN GETZ
208 'required for CreateWindowEx hInstance
209 'Put this in the declarations area of a standard module.
210 Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
211 (ByVal hwnd As Long, _
212 ByVal nIndex As Long) As Long
213
214
215 Private Const GWL_HINSTANCE = (-6)
216
217 'To check the space needed by the control
218 Private Const LOGPIXELSX = 88
219 Private Const LOGPIXELSY = 90
220 Private Const TWIPSPERINCH = 1440
221
222 Private Declare Function GetClientRect Lib "user32" _
223 (ByVal hwnd As Long, lpRect As RECT) As Long
224
225 Private Declare Function GetWindowRect Lib "user32" _
226 (ByVal hwnd As Long, lpRect As RECT) As Long
227
228 Private Declare Function AdjustWindowRect Lib "user32" _
229 (lpRectl As RECT, ByVal dwStyle As Long, ByVal bMenu As Long) As Long
230
231 Private Declare Function AdjustWindowRectEx Lib "user32" _
232 (lpRect As RECT, ByVal dsStyle As Long, ByVal bMenu As Long, ByVal dwEsStyle As Long) As Long
233
234 Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
235
236 Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
237
238 Private Declare Function apiSendMessage Lib "user32" Alias "SendMessageA" _
239 (ByVal hwnd As Long, _
240 ByVal wMsg As Long, _
241 ByVal wParam As Long, _
242 lParam As Any) As Long
243
244 Private Declare Function apiSetWindowPos Lib "user32" Alias "SetWindowPos" _
245 (ByVal hwnd As Long, _
246 ByVal hWndInsertAfter As Long, _
247 ByVal X As Long, _
248 ByVal y As Long, _
249 ByVal cx As Long, _
250 ByVal cy As Long, _
251 ByVal wFlags As Long) As Long
252
253 Private Declare Function apiCreateIC Lib "gdi32" Alias "CreateICA" _
254 (ByVal lpDriverName As String, _
255 ByVal lpDeviceName As String, _
256 ByVal lpOutput As String, _
257 lpInitData As Any) As Long
258
259 Private Declare Function apiGetDeviceCaps Lib "gdi32" Alias "GetDeviceCaps" _
260 (ByVal hdc As Long, _
261 ByVal nIndex As Long) As Long
262
263 Private Declare Function apiDeleteDC Lib "gdi32" Alias "DeleteDC" _
264 (ByVal hdc As Long) As Long
265
266
267
268
269 Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
270 (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
271
272 Private Declare Function GetDesktopWindow Lib "user32" () As Long
273
274 Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
275 (ByVal lpClassName As String, _
276 ByVal lpWindowName As String) As Long
277
278 Private Declare Function Beep Lib "kernel32" _
279 (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long
280
281
282
283 ' Color Types
284 Private Const CTLCOLOR_MSGBOX = 0
285 Private Const CTLCOLOR_EDIT = 1
286 Private Const CTLCOLOR_LISTBOX = 2
287 Private Const CTLCOLOR_BTN = 3
288 Private Const CTLCOLOR_DLG = 4
289 Private Const CTLCOLOR_SCROLLBAR = 5
290 Private Const CTLCOLOR_STATIC = 6
291 Private Const CTLCOLOR_MAX = 8 ' three bits max
292
293 Private Const COLOR_SCROLLBAR = 0
294 Private Const COLOR_BACKGROUND = 1
295 Private Const COLOR_ACTIVECAPTION = 2
296 Private Const COLOR_INACTIVECAPTION = 3
297 Private Const COLOR_MENU = 4
298 Private Const COLOR_WINDOW = 5
299 Private Const COLOR_WINDOWFRAME = 6
300 Private Const COLOR_MENUTEXT = 7
301 Private Const COLOR_WINDOWTEXT = 8
302 Private Const COLOR_CAPTIONTEXT = 9
303 Private Const COLOR_ACTIVEBORDER = 10
304 Private Const COLOR_INACTIVEBORDER = 11
305 Private Const COLOR_APPWORKSPACE = 12
306 Private Const COLOR_HIGHLIGHT = 13
307 Private Const COLOR_HIGHLIGHTTEXT = 14
308 Private Const COLOR_BTNFACE = 15
309 Private Const COLOR_BTNSHADOW = 16
310 Private Const COLOR_GRAYTEXT = 17
311 Private Const COLOR_BTNTEXT = 18
312 Private Const COLOR_INACTIVECAPTIONTEXT = 19
313 Private Const COLOR_BTNHIGHLIGHT = 20
314
315 Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
316
317 'SysMonthCal32 messages
318 Private Const MCM_FIRST = &H1000&
319 Private Const MCM_GETCURSEL = &H1001& '(MCM_FIRST + 1)
320 Private Const MCM_SETCURSEL = (MCM_FIRST + 2)
321 Private Const MCM_GETMINREQRECT = (MCM_FIRST + 9)
322 Private Const MCM_SETMAXSELCOUNT = (MCM_FIRST + 4)
323
324 Private Const MCM_GETRANGE = (MCM_FIRST + 17)
325 Private Const MCM_SETRANGE = (MCM_FIRST + 18)
326
327 'Public Const DTM_SETRANGE = &H1004&
328 Private Const GDTR_MIN = 1
329 Private Const GDTR_MAX = 2
330
331 Private Const MCM_GETSELRANGE = (MCM_FIRST + 5)
332 Private Const MCM_GETMONTHRANGE = (MCM_FIRST + 7)
333
334
335 Private Const MCM_SETCOLOR = (MCM_FIRST + 10)
336 Private Const MCM_GETCOLOR = (MCM_FIRST + 11)
337
338 Private Const MCM_SETTODAY = (MCM_FIRST + 12)
339 Private Const MCM_GETTODAY = (MCM_FIRST + 13)
340 Private Const MCM_SETFIRSTDAYOFWEEK = (MCM_FIRST + 15)
341 Private Const MCM_GETFIRSTDAYOFWEEK = (MCM_FIRST + 16)
342 Private Const MCM_SETDAYSTATE = (MCM_FIRST + 8)
343 Private Const MCM_SETSELRANGE = (MCM_FIRST + 6)
344
345
346 Private Const MCM_GETMAXTODAYWIDTH = (MCM_FIRST + 21)
347
348 'Color part's of the Calendar
349 Private Const MCSC_BACKGROUND = 0 '// the background color (between months)
350 Private Const MCSC_TEXT = 1 '// the dates
351 Private Const MCSC_TITLEBK = 2 '// background of the title
352 Private Const MCSC_TITLETEXT = 3
353 Private Const MCSC_MONTHBK = 4 '// background within the month cal
354 Private Const MCSC_TRAILINGTEXT = 5 '// the text color of header & trailing days
355
356 Private Const MCS_DAYSTATE = &H1
357 Private Const MCS_MULTISELECT = &H2
358 Private Const MCS_WEEKNUMBERS = &H4
359 Private Const MCS_NOTODAYCIRCLE = &H8
360 Private Const MCS_NOTODAY = &H10
361 Private Const GMR_VISIBLE = 0 '// visible portion of display
362 Private Const GMR_DAYSTATE = 1 ' // above plus the grayed out parts of partially displayed months
363
364 ' Window field offsets for GetWindowLong() and GetWindowWord()
365 Private Const GWL_WNDPROC = (-4)
366 'Private Const GWL_HINSTANCE = (-6)
367 Private Const GWL_HWNDPARENT = (-8)
368 Private Const GWL_STYLE = (-16)
369 Private Const GWL_EXSTYLE = (-20)
370 Private Const GWL_USERDATA = (-21)
371 Private Const GWL_ID = (-12)
372
373 Private Const POINTSPERINCH As Long = 72
374
375 Private Const cerrPropertyNotFound As Integer = 3270
376
377 ' Generally use Hex values but
378 ' Decimal is clearer for educational purposes.
379 Const Bit10 = 128
380 Const Bit9 = 128
381 Const Bit8 = 128
382 Const Bit7 = 64
383 Const Bit6 = 32
384 Const Bit5 = 16
385 Const Bit4 = 8
386 Const Bit3 = 4
387 Const Bit2 = 2
388 Const Bit1 = 1
389
390 ' Not used anymore
391 Private Const NotAColor = &HEF000000
392
393 ' Leftover DAO props so that Reference to DAO is no longer required.
394 Private Const dbLongDAO = 4
395 Private Const dbTextDAO = 10
396
397
398 ' Module Level Variables
399
400 ' Junk vars
401 Private lngRet As Long
402 Private blRet As Boolean
403 Private varTemp As Variant
404
405 ' Current Y axis Resolution in Dots per Inch
406 Private lngYdpi As Long
407
408 ' General purpose RECT structure
409 Private udtRECT As RECT
410
411 ' There is a bug in Access when using the SetWindowPos API
412 ' on a Form from an external Class module.
413 ' Specifically if the Form contains a Header or a
414 ' Command Button they are resized along with the Form.
415 ' To get around this we need to store the original
416 ' height of the CommandButton.
417 Private originalCmdButHeight As Integer
418
419 ' hWnd for the Month Calendar control
420 Private m_hWndDTP As Long
421 ' hWnd for the Form used to display the Calendar
422 ' Private m_Form As Access.Form
423
424 'Properties used to create the Month Calendar
425 Private m_MonthColumns As Integer
426 Private m_MonthRows As Integer
427 Private m_SelectedDate As Date
428
429 ' To init SetSelectedDateRange
430 Private m_StartDate As Date
431 Private m_EndDate As Date
432
433 Private m_FontName As String
434 Private m_FontSize As Integer
435 Private m_ShowWeekNumbers As Long
436
437 ' Allow the user to select a Range of Dates
438 Private m_MultiSelect As Long
439
440 ' Max number of days in a user selectable range
441 Private m_MaxSelectRangeofDays As Integer
442
443 Private m_SetRangeOfDays As Long
444
445
446 ' Offset from the Top of our Form where we draw the
447 ' Month Calendar. Allows any controls we have placed at the
448 ' top of the Form to be visible.
449 Private m_CalendarYOffset As Integer
450
451 ' Month Calendar Color props
452 Private m_BackColor As Long
453 Private m_ForeColor As Long
454 Private m_MonthBackColor As Long
455 Private m_TitleBackColor As Long
456 Private m_TitleForeColor As Long
457 Private m_TrailingForeColor As Long
458 ' Original values of above color props
459 ' that exist at time of Calendar creation.
460 ' These color values are as per the Users Window setting
461 Private m_BackColorOrig As Long
462 Private m_ForeColorOrig As Long
463 Private m_MonthBackColorOrig As Long
464 Private m_TitleBackColorOrig As Long
465 Private m_TitleForeColorOrig As Long
466 Private m_TrailingForeColorOrig As Long
467
468 Private m_NoToday As Long
469 Private m_NoTodayCircle As Long
470
471 ' Store current Cursor location for this session
472 Private m_cursorX As Long
473 Private m_cursorY As Long
474 Private m_PositionAtCursor As Boolean
475 ' Cursor coords when Calendar is first loaded
476 Private m_cursorXinitpos As Long
477 Private m_cursorYinitpos As Long
478 ' Positioning of Calendar Window
479 Private m_WindowLocation As Long
480
481 ' Requried to calculate Calendar Height
482 Dim m_TodayHeight As Long
483
484 ' Temp vars to hold the size of our Calendar
485 Private lngTempRight As Long
486 Private lngTempBottom As Long
487 Private hFontPrevious As Long
488
489 Public m_Hwnd As Long
490 Private m_hWndForm As Long
491
492 ' Click once to close the Calendar?
493 Private m_oneClick As Boolean
494
495 ' Max 12 Months displayed at once
496 ' plus one month before and after = 14 months
497 ' Allow for years 1000 to 3000
498 Private BoldDayStates(1000 To 3000, 1 To 14) As MONTHDAYSTATE
499
500 ''' // Create unique naming of Class and unique labeling of Controls Title by using (one!) constant accross this module.
501 ''' // The same constants are used within the modDateTimePicker module.
502 Const CLASSNAME = "MonthCalendar"
503 Const TITLE = "Date Picker:"
504
505 ' Create the Month Calendar
506 Public Sub CreateDTPControl()
507 Dim appHWnd As Long
508
509 ' Only create MonthCalendar if there is a host window
510 If m_Hwnd = 0 Then Exit Sub
511
512 ''' // Get handle to Excel application window
513 If Val(Application.Version) < 10 Then
514 appHWnd = FindWindow("XLMAIN", vbNullString) ''' // < Excel 2000
515 Else
516 appHWnd = Application.hwnd
517 End If
518
519 ' Temp vars
520 Dim udtICC As INITCOMMONCONTROLSEXSTRUCT
521 Dim lngStyle As Long
522 Dim hInstance As Long
523
524 'Temp handle to Information context
525 Dim lngIC As Long
526
527 ''' // If there is an existant DTP destroy it
528 If m_hWndDTP <> 0 Then
529 Call apiDestroyWindow(m_hWndDTP)
530 End If
531
532 ' Courtesy of Ken Getz
533 hInstance = GetWindowLong(appHWnd, GWL_HINSTANCE)
534 udtICC.dwsize = Len(udtICC)
535 udtICC.dwICC = ICC_DATE_CLASSES
536 Call apiInitCommonControlsEx(udtICC)
537
538 ' The Calendar MultiSelect property determines whether the
539 ' user can select a range of dates ' WS_BORDER Or WS_OVERLAPPED
540 lngStyle = WS_BORDER Or WS_CHILD Or m_MultiSelect _
541 Or m_ShowWeekNumbers Or m_NoToday Or m_NoTodayCircle Or m_NoToday Or WS_VISIBLE Or MCS_DAYSTATE ' DayState not ready yet! Or MCS_DAYSTATE
542
543
544 ' Create our Month Calendar
545 m_hWndDTP = apiCreateWindowEx(0&, _
546 "SysMonthCal32", _
547 "DateTimePicker", _
548 lngStyle, _
549 0, _
550 0, _
551 250, _
552 250, _
553 m_Hwnd, _
554 0&, _
555 hInstance, _
556 ByVal 0&)
557
558 ' Modified to allow for different screen resolutions
559 ' and printer output. Needed to Calculate Font size
560 lngIC = apiCreateIC("DISPLAY", vbNullString, vbNullString, vbNullString)
561 If lngIC <> 0 Then
562 lngYdpi = apiGetDeviceCaps(lngIC, LOGPIXELSY)
563 apiDeleteDC (lngIC)
564 Else
565 lngYdpi = 120 'Default average value
566 End If
567
568
569 ' Grab all of the Color props before we mangle them!
570 m_BackColorOrig = BackColor
571 m_ForeColorOrig = ForeColor
572 m_MonthBackColorOrig = MonthBackColor
573 m_TitleBackColorOrig = TitleBackColor
574 m_TitleForeColorOrig = TitleForeColor
575 m_TrailingForeColorOrig = TrailingForeColor
576
577 ' Call our Sub to redraw the Form holding our Calendar
578 ' and position the Calendar appropriately.
579 ReDraw
580 End Sub
581
582
583 Public Sub ReDraw()
584 Dim appHWnd As Long
585 ' Redraw and Position the Parent Form and the Calendar
586
587 ' Only create MonthCalendar if there is a host window
588 If m_Hwnd = 0 Then Exit Sub
589
590 If Val(Application.Version) < 10 Then
591 appHWnd = FindWindow("XLMAIN", vbNullString)
592 Else
593 appHWnd = Application.hwnd
594 End If
595
596 Dim lngXtraPixels As Long
597 ' Make sure the Calendar has time to be initially rendered.
598 DoEvents
599
600 ' Re-render using our props for FontName and FontSize
601 Me.ChangeFont
602
603 ' ****************************
604 ' NOT READY YET!!!!
605 ' TEST FOR DAYSTATE
606 'Me.DayState = 1
607
608 ' Set max range of days user can select
609 Call apiSendMessage(m_hWndDTP, MCM_SETMAXSELCOUNT, m_MaxSelectRangeofDays, ByVal 0&)
610
611 ' If EndDate is Set and MultiSelect then call SetSelectedDateRange
612 If m_EndDate <> 0 And m_EndDate <> 0 And m_MultiSelect = MCS_MULTISELECT Then
613 SetSelectedDateRange m_StartDate, m_EndDate
614 Else
615
616 Dim udtST As SYSTEMTIME
617 With udtST
618 .wYear = year(m_StartDate)
619 .wMonth = month(m_StartDate)
620 .wDay = day(m_StartDate)
621 End With
622 Call apiSendMessage(m_hWndDTP, MCM_SETCURSEL, ByVal 0&, udtST)
623 End If
624
625 ' Get the size required to display 1 complete month of the calendar.
626 Call apiSendMessage(m_hWndDTP, MCM_GETMINREQRECT, ByVal 0&, udtRECT)
627
628 ' Check is TODAY is showing at bottom of Calendar
629 If m_NoToday = 0 Then
630 lngXtraPixels = apiSendMessage(m_hWndDTP, MCM_GETMAXTODAYWIDTH, ByVal 0&, ByVal 0&)
631 Else
632 lngXtraPixels = udtRECT.Right ' = lngXtraPixels
633 End If
634
635 ' Set color props
636 If m_BackColor <> NotAColor Then
637 Call apiSendMessage(m_hWndDTP, MCM_SETCOLOR, MCSC_BACKGROUND, ByVal m_BackColor)
638 End If
639
640 If m_ForeColor <> NotAColor Then
641 Call apiSendMessage(m_hWndDTP, MCM_SETCOLOR, MCSC_TEXT, ByVal m_ForeColor)
642 End If
643
644 If m_MonthBackColor <> NotAColor Then
645 Call apiSendMessage(m_hWndDTP, MCM_SETCOLOR, MCSC_MONTHBK, ByVal m_MonthBackColor)
646 End If
647
648 If m_TitleForeColor <> NotAColor Then
649 Call apiSendMessage(m_hWndDTP, MCM_SETCOLOR, MCSC_TITLETEXT, ByVal m_TitleForeColor)
650 End If
651
652 If m_TitleBackColor <> NotAColor Then
653 Call apiSendMessage(m_hWndDTP, MCM_SETCOLOR, MCSC_TITLEBK, ByVal m_TitleBackColor)
654 End If
655
656 If m_TrailingForeColor <> NotAColor Then
657 Call apiSendMessage(m_hWndDTP, MCM_SETCOLOR, MCSC_TRAILINGTEXT, ByVal m_TrailingForeColor)
658 End If
659
660 ' This is the function to tell us what size the window would be
661 ' to hold the entire Client Rectangle area. In other words it adds
662 ' on the height for the Title Bar, Bottom Border etc.
663 Dim rc1 As RECT
664 Dim rc2 As RECT
665 Dim rc3 As RECT
666 Dim BarBordersY As Integer
667 Dim BarBordersX As Integer
668
669 ' Get rectangle for our Form
670 ' Debug.Print "GetWindowRect- Me.hWnd:" & m_Form.hWnd
671 lngRet = GetWindowRect(m_hWndDTP, rc1)
672 lngRet = GetClientRect(m_hWndDTP, rc2)
673 ' Calculate Borders and Title Bar area.
674 BarBordersY = ((rc1.Bottom - rc1.Top) - (rc2.Bottom - rc2.Top)) + 10
675 BarBordersX = ((rc1.Right - rc1.Left) - (rc2.Right - rc2.Left)) + 10
676
677 With udtRECT
678 ' Handle possible extra Today string Width
679 udtRECT.Right = lngXtraPixels
680
681 ' An OS bug/feature requires us to round up
682 If m_NoToday <> 0 Then
683 lngTempRight = (.Right * m_MonthColumns) + (m_MonthColumns - 1) * 6 'BarBordersX 'm_MonthColumns * 2 '5
684 lngTempBottom = (.Bottom * m_MonthRows) + (m_MonthRows * (m_TodayHeight * 1.5)) ' (m_TodayHeight * 4) '(m_MonthRows - 1) * 24 '12 'BarBordersY 'm_MonthRows * m_TodayHeight ')) ' + 10 ''m_MonthRows * 15
685 ' ADD CODE TO HELP WITH NUMBER OF ROWS.
686 ' If only 1 run then only need *2 or *3
687 Else
688 lngTempRight = (.Right * m_MonthColumns) + (m_MonthColumns - 1) * 6 'BarBordersX '+ m_MonthColumns * 2 '5
689 lngTempBottom = (.Bottom * m_MonthRows) ' + (m_MonthRows - 1) * 1 '12 'BarBordersY '+ m_MonthRows * 10
690 End If
691 End With
692
693 ' Resize the Month Calendar to display the user selected
694 ' number of months. The CalendarYOffset is used to allow
695 ' any controls we have placed at the Top of our Form
696 ' to be visible.
697 ' ***DEBUG - BUG FIX ******
698 ' Try to fix visual display bug
699 ' when only 1 month is selected.
700 ' The left most column dissappears when
701 ' when selecting a range of dates
702 ' Add 4 pixels to the COntrol's Width
703
704 If m_MonthRows = 1 And m_MonthColumns = 1 Then
705 Call apiSetWindowPos(m_hWndDTP, 0&, 0&, _
706 0&, lngTempRight + 4, lngTempBottom, 0&)
707 Else
708 Call apiSetWindowPos(m_hWndDTP, 0&, 0&, _
709 0&, lngTempRight, lngTempBottom, 0&)
710 End If
711
712 ' Get rectangle for our Form
713 ' Debug.Print "GetWindowRect- Me.hWnd:" & m_Form.hWnd
714 ' lngRet = GetWindowRect(m_Hwnd, rc1)
715 ' lngRet = GetClientRect(m_Hwnd, rc2)
716 ' Get rectangle for our Calendar
717 lngRet = GetWindowRect(m_hWndDTP, rc3)
718
719 lngRet = GetWindowLong(m_Hwnd, GWL_STYLE)
720 lngRet = AdjustWindowRect(rc3, lngRet, -1)
721
722 ' Resize our Form to display the entire Calendar
723 ' Position Window at current cursor location.
724 ' We will use the Cursor location when the Window was first
725 ' created, not the current location. User could be
726 ' selecting a Menu when this Redraw Sub is called.
727 ' We also need to allow the user to manually move
728 ' and place this window and respect those
729 ' coordinates for this session.
730 ' So if the current XY WIndow Coords are not the same
731 ' as the stored Mouse Coords then let the current
732 ' Calendars Parent Window coords stand.
733 ' We do this directly in the Windows Procedure
734 ' by resetting the CursorX and CursorY props
735 ' on the Window Move message.
736
737 If m_PositionAtCursor Then
738 ' Position Window at Cursor Location when
739 ' Calendar was created.
740
741 ' Also add an option to position cursor itself in middle of calendar window
742 ' May 05 - update m_cursorXinitpos and m_cursorYinitpos to reflect current cursor location when this calendar is opened
743 ' This is done in the modCalendar module when the parent window for the Calendar is created.
744
745 'June 7, 2003 fixing position at cursor logic
746 ' PositionAtCursor = True
747
748 ' First check to ensure entire calendar window will fit.
749 ' If not MAKE IT!
750 ' COMING IN NEXT RELEASE!
751 With udtRECT
752 Call apiSetWindowPos(m_Hwnd, 0&, m_cursorX, m_cursorY, rc3.Right - rc3.Left, _
753 rc3.Bottom - rc3.Top, 0&)
754 End With
755
756 Else
757 ' Position Window according to users Menu selections
758 ' a) 0 -Pop at cursor location when user activates Calendar
759 ' b) 1 -Where they manually move/leave it at
760 ' c) 2 -Centered in Access App Window
761 ' d) 3 -Centered on entire screen
762 ' d) 4 -Top Left Corner
763 ' Debug.Print "m_WindowLocation:" & m_WindowLocation
764
765 Select Case m_WindowLocation
766 Case 1
767 With udtRECT
768 Call apiSetWindowPos(m_Hwnd, 0&, m_cursorX, m_cursorY, rc3.Right - rc3.Left, _
769 rc3.Bottom - rc3.Top, 0&)
770 End With
771 Case 2
772 ' Centered within main Access App Window
773 ' Get rectangle for our Calendar
774 lngRet = GetWindowRect(appHWnd, rc2)
775 With udtRECT
776 Call apiSetWindowPos(m_Hwnd, 0&, ((rc2.Right - rc2.Left) - (rc3.Right - rc3.Left)) / 2, _
777 ((rc2.Bottom - rc2.Top) - (rc3.Bottom - rc3.Top)) / 2, rc3.Right - rc3.Left, _
778 rc3.Bottom - rc3.Top, 0&)
779 End With
780 Case 3
781 ' Centered within Screen
782 ' Get rectangle for our Calendar
783 Dim hWndDeskTop As Long
784 hWndDeskTop = GetDesktopWindow()
785 lngRet = GetWindowRect(hWndDeskTop, rc2)
786 With udtRECT
787 Call apiSetWindowPos(m_Hwnd, 0&, ((rc2.Right - rc2.Left) - (rc3.Right - rc3.Left)) / 2, _
788 ((rc2.Bottom - rc2.Top) - (rc3.Bottom - rc3.Top)) / 2, rc3.Right - rc3.Left, _
789 rc3.Bottom - rc3.Top, 0&)
790 End With
791 Case 4
792 ' Upper Left Hand Corner of Screen
793 ' Get rectangle for our Calendar
794 lngRet = GetWindowRect(hWndDeskTop, rc2)
795 With udtRECT
796 Call apiSetWindowPos(m_Hwnd, 0&, 2, _
797 2, rc3.Right - rc3.Left, _
798 rc3.Bottom - rc3.Top, 0&)
799 End With
800 Case Else
801 With udtRECT
802 Call apiSetWindowPos(m_Hwnd, 0&, m_cursorX, m_cursorY, rc3.Right - rc3.Left, _
803 rc3.Bottom - rc3.Top, 0&)
804 End With
805 End Select
806 End If
807 End Sub
808
809 Public Sub ResetCalendarColors()
810 ' Reset all of the color props to their original setting
811 ' as per the users system settings for the GUI.
812 BackColor = m_BackColorOrig
813 ForeColor = m_ForeColorOrig
814 MonthBackColor = m_MonthBackColorOrig
815 TitleBackColor = m_TitleBackColorOrig
816 TitleForeColor = m_TitleForeColorOrig
817 TrailingForeColor = m_TrailingForeColorOrig
818 End Sub
819
820
821 ''' // Ver.: 3.0.0; 22.05.2009; (c) digital-ecom GmbH
822 ''' // Allow specifying a restriced date range
823 Public Function SetDateRange(TimeArray As Variant)
824 Dim sSystemTime(1) As SYSTEMTIME
825
826 sSystemTime(0).wDay = TimeArray(0, 0)
827 sSystemTime(0).wMonth = TimeArray(1, 0)
828 sSystemTime(0).wYear = TimeArray(2, 0)
829
830 sSystemTime(1).wDay = TimeArray(0, 1)
831 sSystemTime(1).wMonth = TimeArray(1, 1)
832 sSystemTime(1).wYear = TimeArray(2, 1)
833
834 Call apiSendMessage(m_hWndDTP, MCM_SETRANGE, GDTR_MIN + GDTR_MAX, ByVal sSystemTime(0))
835 End Function
836
837
838 Public Property Let MultiSelect(ms As Boolean)
839 ' Allow user to select a Range of dates instead of just one.
840 If ms Then
841 m_MultiSelect = MCS_MULTISELECT
842 Else
843 m_MultiSelect = 0
844 End If
845 ' Update custom property
846 SetProperty "MultiSelect", dbLongDAO, m_MultiSelect
847 End Property
848
849 Public Property Get MultiSelect() As Boolean
850 If m_MultiSelect = MCS_MULTISELECT Then
851 MultiSelect = True
852 Else
853 MultiSelect = False
854 End If
855 End Property
856
857 Public Property Let MaxSelectRangeofDays(maxdays As Integer)
858 ' Maximum days user can select in a range of dates.
859 If maxdays > 365 Or maxdays < 0 Then
860 m_MaxSelectRangeofDays = 7
861 Else
862 m_MaxSelectRangeofDays = maxdays
863 End If
864 CreateDTPControl
865 End Property
866
867 Public Property Get MaxSelectRangeofDays() As Integer
868 MaxSelectRangeofDays = m_MaxSelectRangeofDays
869 End Property
870
871 Public Property Let CalendarYOffset(YOffset As Integer)
872 ' Offset from the Top of our Form where we will
873 ' draw our Calendat. This will leave us room at the
874 ' the top of our Form for our controls.
875 ' Some boundary checking. We'll arbitrarily use 3 inches for now.
876 ' This prop is expressed in TWIPS!
877 If YOffset > 3 * TWIPSPERINCH Or YOffset < 0 Then
878 m_CalendarYOffset = 0
879 Else
880 m_CalendarYOffset = YOffset
881 End If
882 'CreateDTPControl
883 End Property
884
885 Public Property Get CalendarYOffset() As Integer
886 CalendarYOffset = m_CalendarYOffset
887 End Property
888
889 Public Property Let MonthRows(ByVal newMonthRows As Byte)
890 ' The Month Calendar allows for a maximum of 12 months
891 ' to be displayed at once.
892 If newMonthRows > 12 Or newMonthRows < 0 Then
893 newMonthRows = 1
894 End If
895 If newMonthRows * m_MonthColumns > 12 Then
896 m_MonthRows = 12 / m_MonthColumns
897 Else
898 m_MonthRows = newMonthRows
899 End If
900
901 ' Update custom property
902 Call SetProperty("MonthRows", dbLongDAO, m_MonthRows)
903 End Property
904
905 Public Property Get MonthRows() As Byte
906 MonthRows = m_MonthRows
907 End Property
908
909 Public Property Let MonthColumns(ByVal newMonthColumns As Byte)
910 ' The Month Calendar allows for a maximum of 12 months
911 ' to be displayed at once.
912 If newMonthColumns > 12 Or newMonthColumns < 0 Then
913 newMonthColumns = 1
914 End If
915
916 If newMonthColumns * m_MonthRows > 12 Then
917 m_MonthColumns = 12 / m_MonthRows
918 Else
919 m_MonthColumns = newMonthColumns
920 End If
921 ' Update custom property
922 Call SetProperty("MonthColumns", dbLongDAO, m_MonthColumns)
923 End Property
924
925 Public Property Get MonthColumns() As Byte
926 MonthColumns = m_MonthColumns
927 End Property
928
929 Public Property Let WindowLocation(loc As Long)
930 ' Allow user to select position of Calendar Window
931 'Debug.Print "Prop Let:" & loc
932 If loc < 0 Or loc > 4 Then
933 m_WindowLocation = 0
934 Else
935 m_WindowLocation = loc
936 End If
937
938 ' Update custom property
939 SetProperty "WindowLocation", dbLongDAO, m_WindowLocation
940 'Debug.Print "Saved Prop :" & m_WindowLocation
941 End Property
942
943 Public Property Get WindowLocation() As Long
944 WindowLocation = m_WindowLocation
945 End Property
946
947
948 Public Property Let PositionAtCursor(bl As Boolean)
949 ' Does user want to popup Calendar at Current Cursor location
950 ' When they invoke the Calendar?
951 Dim pt As POINTAPI
952 m_PositionAtCursor = bl
953 If bl Then
954 ' lngRet = GetCursorPos(pt)
955 m_cursorX = m_cursorXinitpos
956 m_cursorY = m_cursorYinitpos
957 End If
958 End Property
959
960
961 Public Property Get PositionAtCursor() As Boolean
962 PositionAtCursor = m_PositionAtCursor
963 End Property
964
965
966 Public Property Let CursorXinit(X As Long)
967 ' Store Cursor position
968 m_cursorXinitpos = X
969 If Me.PositionAtCursor = True Then
970 m_cursorX = X
971 End If
972 ' Update custom property
973 'Call SetProperty("CursorX", dbLongDAO, m_cursorX)
974 End Property
975
976 Public Property Let CursorYinit(y As Long)
977 ' Store Cursor position
978 m_cursorYinitpos = y
979 If Me.PositionAtCursor = True Then
980 m_cursorY = y
981 End If
982 ' Redraw the control
983 CreateDTPControl
984 ' Update custom property
985 'Call SetProperty("CursorY", dbLongDAO, m_cursorY)
986 End Property
987
988 Public Property Let CursorX(X As Long)
989 ' X pos.
990 m_cursorX = X
991 ' Update custom property
992 Call SetProperty("CursorX", dbLongDAO, m_cursorX)
993 End Property
994
995 Public Property Let CursorY(y As Long)
996 ' Y pos.
997 m_cursorY = y
998 ' Update custom property
999 Call SetProperty("CursorY", dbLongDAO, m_cursorY)
1000 End Property
1001
1002
1003 Public Property Get CursorX() As Long
1004 ' X pos.
1005 CursorX = m_cursorX
1006 End Property
1007
1008 Public Property Get CursorY() As Long
1009 ' Y Pos.
1010 CursorY = m_cursorY
1011 End Property
1012
1013
1014 Public Property Let FontSize(FS As Integer)
1015 ' Font Size to render the Calendar with.
1016 If FS = 0 Or FS < 0 Then FS = 8
1017 If FS > 24 Then FS = 8
1018 m_FontSize = FS
1019 ' Update custom property
1020 SetProperty "FontSize", dbLongDAO, m_FontSize
1021 End Property
1022
1023 Public Property Get FontSize() As Integer
1024 FontSize = m_FontSize
1025 End Property
1026
1027 Public Property Let FontName(fn As String)
1028 ' Font Name to render the Calendar with.
1029 m_FontName = fn
1030 ' Update custom property
1031 Call SetProperty("FontName", dbTextDAO, m_FontName)
1032 End Property
1033
1034 Public Property Get FontName() As String
1035 FontName = m_FontName
1036 End Property
1037
1038 Public Property Let ShowWeekNumbers(bl As Boolean)
1039 ' Show Week Numbers
1040 If bl Then
1041 m_ShowWeekNumbers = MCS_WEEKNUMBERS
1042 Else
1043 m_ShowWeekNumbers = 0
1044 End If
1045 ' Update custom property
1046 Call SetProperty("MCS_WEEKNUMBERS", dbLongDAO, m_ShowWeekNumbers)
1047
1048 ' Redraw the control
1049 CreateDTPControl
1050 End Property
1051
1052 Public Property Get ShowWeekNumbers() As Boolean
1053 If m_ShowWeekNumbers = MCS_WEEKNUMBERS Then
1054 ShowWeekNumbers = True
1055 Else
1056 ShowWeekNumbers = False
1057 End If
1058 End Property
1059
1060 Public Property Get NoTodayCircle() As Boolean
1061 If m_NoTodayCircle = 0 Then
1062 NoTodayCircle = False
1063 Else
1064 NoTodayCircle = True
1065 End If
1066 End Property
1067
1068 Public Property Let NoTodayCircle(bl As Boolean)
1069 ' Show Circle around Today's Date
1070 If bl Then
1071 m_NoTodayCircle = MCS_NOTODAYCIRCLE
1072 Else
1073 m_NoTodayCircle = 0
1074 End If
1075
1076 ' Update custom property
1077 Call SetProperty("NoTodayCircle", dbLongDAO, m_NoTodayCircle)
1078
1079 ' Redraw the control
1080 CreateDTPControl
1081 End Property
1082
1083 Public Property Get NoToday() As Boolean
1084 If m_NoToday = 0 Then
1085 NoToday = False
1086 Else
1087 NoToday = True
1088 End If
1089 End Property
1090
1091 Public Property Let NoToday(bl As Boolean)
1092 ' Show Today's date at bottom of Calendar
1093 If bl Then
1094 m_NoToday = MCS_NOTODAY
1095 Else
1096 m_NoToday = 0
1097 End If
1098 ' Update custom property
1099 Call SetProperty("NoToday", dbLongDAO, m_NoToday)
1100
1101 ' Redraw the control
1102 CreateDTPControl
1103 End Property
1104
1105
1106 Public Property Let hwnd(h As Long)
1107 ' Host Window
1108 m_Hwnd = h
1109
1110 ' ReCreate the control
1111 CreateDTPControl
1112 End Property
1113
1114 Public Property Get hwnd() As Long
1115 ' MonthCalendar Parent Window
1116 hwnd = m_Hwnd
1117 End Property
1118
1119 Public Property Let hWndForm(h As Long)
1120 ' Calling Form's Window Handle
1121 m_hWndForm = h
1122 End Property
1123
1124 Public Property Get hWndForm() As Long
1125 ' Calling Form's Window Handle
1126 hWndForm = m_hWndForm
1127 End Property
1128
1129
1130 Public Property Get hWndCal() As Long
1131 ' MonthCalendar Window
1132 hWndCal = m_hWndDTP
1133 End Property
1134
1135 Public Property Let OneClick(bl As Boolean)
1136 ' Click Once to Close our Calendar.
1137 m_oneClick = bl
1138 ' Update custom property
1139 Call SetProperty("OneClick", dbLongDAO, m_oneClick)
1140 End Property
1141
1142 Public Property Get OneClick() As Boolean
1143 OneClick = m_oneClick
1144 End Property
1145
1146 Public Property Let SelectedDate(ByVal newSelectedDate As Date)
1147 ' Date pre-selected in the Calendar.
1148 ' Default is Today's date.
1149 Dim udtST As SYSTEMTIME
1150 m_SelectedDate = newSelectedDate
1151 With udtST
1152 .wYear = year(newSelectedDate)
1153 .wMonth = month(newSelectedDate)
1154 .wDay = day(newSelectedDate)
1155 End With
1156
1157 m_StartDate = newSelectedDate
1158 If m_MultiSelect <> MCS_MULTISELECT Then
1159 Call apiSendMessage(m_hWndDTP, MCM_SETCURSEL, ByVal 0&, udtST)
1160 Else
1161 m_StartDate = newSelectedDate
1162 m_EndDate = m_StartDate
1163 Call SetSelectedDateRange(m_StartDate, m_EndDate)
1164 ' Sets the
1165 End If
1166 End Property
1167
1168
1169 Public Sub SetSelectedDateRange(ByVal StartDate As Date, ByVal EndDate As Date)
1170 ' Sets the Range of Dates visible in the Calendar
1171 Dim udtST(1) As SYSTEMTIME
1172
1173 If m_MultiSelect <> MCS_MULTISELECT Then Exit Sub
1174
1175 ' Fill in the start and ending SYSTEMTIME structures
1176 With udtST(0)
1177 .wDay = day(StartDate)
1178 .wMonth = month(StartDate)
1179 .wYear = year(StartDate)
1180 End With
1181
1182 With udtST(1)
1183 .wDay = day(EndDate)
1184 .wMonth = month(EndDate)
1185 .wYear = year(EndDate)
1186 End With
1187 lngRet = apiSendMessage(m_hWndDTP, MCM_SETSELRANGE, ByVal 0&, udtST(0))
1188 With udtST(0)
1189 m_SelectedDate = DateSerial(.wYear, .wMonth, .wDay)
1190 End With
1191 'With udtST(1)
1192 ' m_endSelectedDate = DateSerial(.wYear, .wMonth, .wDay)
1193 'End With
1194 End Sub
1195
1196
1197 Public Property Get StartSelectedDate() As Date
1198 ' Either the current single date selected by the user
1199 ' or the First date in a user selected range of dates.
1200 Dim udtST As SYSTEMTIME
1201
1202 If m_MultiSelect = MCS_MULTISELECT Then
1203 StartSelectedDate = GetSelectedDates(True)
1204 Else
1205 Call apiSendMessage(m_hWndDTP, MCM_GETCURSEL, ByVal 0&, udtST)
1206 With udtST
1207 m_SelectedDate = DateSerial(.wYear, .wMonth, .wDay)
1208 End With
1209 StartSelectedDate = m_SelectedDate
1210 End If
1211 End Property
1212
1213 Public Property Get EndSelectedDate() As Date
1214 ' The End date in a user selected range of dates.
1215 Dim udtST As SYSTEMTIME
1216
1217 If m_MultiSelect = MCS_MULTISELECT Then
1218 EndSelectedDate = GetSelectedDates(False)
1219 Else
1220 Call apiSendMessage(m_hWndDTP, MCM_GETCURSEL, ByVal 0&, udtST)
1221 With udtST
1222 m_SelectedDate = DateSerial(.wYear, .wMonth, .wDay)
1223 End With
1224 EndSelectedDate = m_SelectedDate
1225 End If
1226 End Property
1227
1228 Private Function GetSelectedDates(StartEnd As Boolean) As Date
1229 ' Return Start or END date of user selected Range
1230 ' If StartEnd = TRUE then return Start Date
1231 ' If StartEnd = FALSE then return END Date
1232 Dim arrayTime(0 To 1) As SYSTEMTIME
1233 Dim DateStart As Date
1234 Dim DateEnd As Date
1235
1236 ' Get the currently selected range
1237 lngRet = apiSendMessage(m_hWndDTP, MCM_GETSELRANGE&, ByVal 0&, arrayTime(0))
1238
1239 ' Convert to our Date format
1240 With arrayTime(0)
1241 DateStart = DateSerial(.wYear, .wMonth, .wDay)
1242 End With
1243 With arrayTime(1)
1244 DateEnd = DateSerial(.wYear, .wMonth, .wDay)
1245 End With
1246
1247 ' Return specified Start or End date
1248 If StartEnd Then
1249 GetSelectedDates = DateStart
1250 Else
1251 GetSelectedDates = DateEnd
1252 End If
1253 End Function
1254
1255 Public Sub SetViewableMonths(numMonths As Integer)
1256 ' How many months are viewable in the Calendar.
1257 ' Options are 1,2,3,4,6,9,12
1258
1259 Select Case numMonths
1260 Case 1
1261 MonthColumns = 1
1262 MonthRows = 1
1263
1264 Case 2
1265 MonthColumns = 2
1266 MonthRows = 1
1267
1268 Case 3
1269 MonthColumns = 3
1270 MonthRows = 1
1271
1272 Case 4
1273 MonthColumns = 2
1274 MonthRows = 2
1275
1276 Case 6
1277 MonthColumns = 3
1278 MonthRows = 2
1279
1280 Case 8
1281 MonthColumns = 4
1282 MonthRows = 2
1283
1284 Case 9
1285 MonthColumns = 3
1286 MonthRows = 3
1287
1288 Case 12
1289 MonthColumns = 4
1290 MonthRows = 3
1291
1292 Case Else
1293 MonthColumns = 1
1294 MonthRows = 1
1295
1296 End Select
1297
1298 ' Create the new Month Calender
1299 If m_hWndDTP = 0 Then
1300 CreateDTPControl
1301 Else
1302 ReDraw
1303 End If
1304 End Sub
1305
1306 Public Sub SelectFont()
1307 Dim f As FormFontInfo
1308
1309 ' Set some Defaults for the Font Dialog
1310 With f
1311 .Color = 0
1312 .Height = m_FontSize '12
1313 .Weight = 400
1314 .Italic = False
1315 .UnderLine = False
1316 .name = m_FontName '"Arial"
1317 End With
1318
1319 ' Call the Font Dialog
1320 blRet = DialogFont(f, m_hWndDTP)
1321 If blRet Then
1322 ' Copy users selections over to
1323 ' our class vars
1324 With f
1325 FontName = .name
1326 FontSize = .Height
1327 End With
1328 ' store selection to Custom Property
1329 ReDraw
1330 End If
1331 End Sub
1332
1333
1334 Public Sub ChangeFont()
1335
1336 ' ******************
1337 ' DEBUG
1338 ' ******************
1339
1340 'Exit Sub
1341
1342
1343 ' User selectable Font size for the Calendar.
1344 ' From limited testing it seems the Calendar
1345 ' deletes the Font we pass to it. Needs further
1346 ' testing though!
1347
1348 ' Font Height in Device Pixels
1349 Dim fheight As Integer
1350
1351 ' Declared at module level so that I can DeleteObject
1352 ' on all fonts I create
1353 'Dim hFontPrevious As Long
1354
1355 ' Newly created Font
1356 Dim hFont As Long
1357
1358 ' Calculate/Convert requested Font Height
1359 ' into Font's Device Coordinate space
1360 fheight = apiMulDiv(m_FontSize, lngYdpi, 72)
1361
1362 ' We use a negative value to signify
1363 ' to the CreateFont function that we want a Glyph
1364 ' outline of this size not a bounding box.
1365
1366 hFont = apiCreateFont(-fheight, 0, _
1367 0, 0, 400, _
1368 0, 0, _
1369 0, 0, 0, _
1370 0, 0, 0, m_FontName) '"Verdana")
1371
1372 lngRet = apiSendMessage(m_hWndDTP, WM_SETFONT, hFont, ByVal -1)
1373
1374 If hFontPrevious <> 0 Then
1375 DeleteObject hFontPrevious
1376 End If
1377
1378 ' Store current Font into Previous var
1379 hFontPrevious = hFont
1380
1381 DoEvents
1382
1383 ' Let's compute the height of 1 line of Text with this Font
1384 ' This figure willbe added to the desired window height
1385 ' of the Calendar when the NoToday flag is TRUE
1386 ' Store the results in the module level var m_TodayHeight
1387 Dim sngTemp As Single
1388 sngTemp = CSng(m_FontSize) / CSng(POINTSPERINCH)
1389 sngTemp = sngTemp * CSng(lngYdpi)
1390 m_TodayHeight = CLng(sngTemp)
1391 'ReDraw
1392 End Sub
1393
1394 Public Sub ChooseColors(index As Long)
1395 ' Index is the color index
1396 Dim lngNewColor As Long
1397 ' Call the Color Dialog Window
1398
1399 lngNewColor = aDialogColor(m_hWndDTP) ' Apr 02/2004 Dialog was behind CalendarApplication.hWndAccessApp)
1400 ' User did not pick a color
1401 If lngNewColor = -1 Then Exit Sub
1402
1403 ' Save users selection into the corresponding property
1404 Select Case index
1405 Case MCSC_BACKGROUND
1406 BackColor = lngNewColor
1407
1408 Case MCSC_MONTHBK
1409 MonthBackColor = lngNewColor
1410
1411 Case MCSC_TEXT
1412 ForeColor = lngNewColor
1413
1414 Case MCSC_TITLEBK
1415 TitleBackColor = lngNewColor
1416
1417 Case MCSC_TITLETEXT
1418 TitleForeColor = lngNewColor
1419
1420 Case MCSC_TRAILINGTEXT
1421 TrailingForeColor = lngNewColor
1422
1423 Case Else
1424 End Select
1425
1426 End Sub
1427
1428 Public Property Let BackColor(ByVal newColor As Long)
1429 m_BackColor = newColor
1430 'If the control is allready created set the Back Color
1431 'Debug.Print Hex(newColor)
1432 If m_hWndDTP <> 0 Then
1433 Call apiSendMessage(m_hWndDTP, MCM_SETCOLOR, MCSC_BACKGROUND, ByVal newColor)
1434 End If
1435 ' Update custom property
1436 Call SetProperty("BackColor", dbLongDAO, m_BackColor)
1437 End Property
1438
1439 Public Property Get BackColor() As Long
1440 lngRet = apiSendMessage(m_hWndDTP, MCM_GETCOLOR, MCSC_BACKGROUND, 0&)
1441 BackColor = lngRet
1442 End Property
1443
1444 Public Property Let ForeColor(ByVal newColor As Long)
1445 m_ForeColor = newColor
1446 'If the control is allready created set the Fore Color
1447 If m_hWndDTP <> 0 Then
1448 Call apiSendMessage(m_hWndDTP, MCM_SETCOLOR, MCSC_TEXT, ByVal newColor)
1449 End If
1450 ' Update custom property
1451 Call SetProperty("ForeColor", dbLongDAO, m_ForeColor)
1452 End Property
1453
1454 Public Property Get ForeColor() As Long
1455 lngRet = apiSendMessage(m_hWndDTP, MCM_GETCOLOR, MCSC_TEXT, 0&)
1456 ForeColor = lngRet
1457 End Property
1458
1459 Public Property Let MonthBackColor(ByVal newColor As Long)
1460 m_MonthBackColor = newColor
1461 'If the control is allready created set the Month Back Color
1462 If m_hWndDTP <> 0 Then
1463 Call apiSendMessage(m_hWndDTP, MCM_SETCOLOR, MCSC_MONTHBK, ByVal newColor)
1464 End If
1465 ' Update custom property
1466 Call SetProperty("MonthBackColor", dbLongDAO, m_MonthBackColor)
1467 End Property
1468
1469 Public Property Get MonthBackColor() As Long
1470 lngRet = apiSendMessage(m_hWndDTP, MCM_GETCOLOR, MCSC_MONTHBK, 0&)
1471 MonthBackColor = lngRet
1472 End Property
1473
1474 Public Property Let TitleBackColor(ByVal newColor As Long)
1475 m_TitleBackColor = newColor
1476 'If the control is allready created set the Title Back Color
1477 If m_hWndDTP <> 0 Then
1478 Call apiSendMessage(m_hWndDTP, MCM_SETCOLOR, MCSC_TITLEBK, ByVal newColor)
1479 End If
1480 ' Update custom property
1481 Call SetProperty("TitleBackColor", dbLongDAO, m_TitleBackColor)
1482 End Property
1483
1484 Public Property Get TitleBackColor() As Long
1485 lngRet = apiSendMessage(m_hWndDTP, MCM_GETCOLOR, MCSC_TITLEBK, 0&)
1486 TitleBackColor = lngRet
1487 End Property
1488
1489 Public Property Let TitleForeColor(ByVal newColor As Long)
1490 m_TitleForeColor = newColor
1491 'If the control is allready created set the Title Fore Color
1492 If m_hWndDTP <> 0 Then
1493 Call apiSendMessage(m_hWndDTP, MCM_SETCOLOR, MCSC_TITLETEXT, ByVal newColor)
1494 End If
1495
1496 ' Update custom property
1497 Call SetProperty("TitleForeColor", dbLongDAO, m_TitleForeColor)
1498 End Property
1499 Public Property Get TitleForeColor() As Long
1500 lngRet = apiSendMessage(m_hWndDTP, MCM_GETCOLOR, MCSC_TITLETEXT, 0&)
1501 TitleForeColor = lngRet
1502 End Property
1503
1504 Public Property Let TrailingForeColor(ByVal newColor As Long)
1505 m_TrailingForeColor = newColor
1506 'If the control is allready created set the Title Fore Color
1507 If m_hWndDTP <> 0 Then
1508 Call apiSendMessage(m_hWndDTP, MCM_SETCOLOR, MCSC_TRAILINGTEXT, ByVal newColor)
1509 End If
1510 ' Update custom property
1511 Call SetProperty("TrailingForeColor", dbLongDAO, m_TrailingForeColor)
1512 End Property
1513
1514 Public Property Get TrailingForeColor() As Long
1515 lngRet = apiSendMessage(m_hWndDTP, MCM_GETCOLOR, MCSC_TRAILINGTEXT, 0&)
1516 TrailingForeColor = lngRet
1517 End Property
1518
1519
1520
1521 Public Property Let DAYSTATE(ByVal month As Long)
1522 ' *****************************
1523 ' Use the SetBoldDayState function instead
1524
1525 ' *****************************
1526
1527 ' If MonthCal does not exist then exit.
1528 '
1529 'If m_hWndDTP = 0 Then Exit Property
1530 '
1531 ''(DWORD)SNDMSG(hmc, MCM_GETMONTHRANGE, (WPARAM)(gmr), (LPARAM)(rgst))
1532 'Dim arrayTime(0 To 1) As SYSTEMTIME
1533 'Dim arrayDayStates() As MONTHDAYSTATE
1534 '
1535 'Dim DateStart As Date
1536 'Dim DateEnd As Date
1537 'Dim VisibleMonths As Long
1538 'Dim StartMonth As Long
1539 'Dim EndMonth As Long
1540 'Dim ctr As Long
1541 '' Get the currently selected range
1542 'VisibleMonths = apiSendMessage(m_hWndDTP, MCM_GETMONTHRANGE, ByVal GMR_DAYSTATE, arrayTime(0))
1543 ' If VisibleMonths = 0 Then Exit Property
1544 'ReDim arrayDayStates(VisibleMonths - 1)
1545 '' What is First visible month
1546 'StartMonth = arrayTime(0).wMonth
1547 '
1548 'For ctr = 0 To VisibleMonths - 1
1549 ' arrayDayStates(ctr).lpMONTHDAYSTATE = BoldDayStates(StartMonth).lpMONTHDAYSTATE
1550 ' StartMonth = StartMonth + 1
1551 ' ' Rollover after 12 months
1552 ' If StartMonth = 13 Then StartMonth = 1
1553 'Next ctr
1554 '
1555 'lngRet = apiSendMessage(m_hWndDTP, MCM_SETDAYSTATE, UBound(arrayDayStates) + 1, arrayDayStates(0))
1556 '
1557 '
1558 End Property
1559 Public Function GetDAYSTATE(ByVal year As Long, ByVal month As Long) As Long
1560 GetDAYSTATE = BoldDayStates(year, month).lpMONTHDAYSTATE
1561 End Function
1562
1563
1564
1565
1566 ' Turn on Bolding for specified days of the month
1567 ' Use named arguments when calling this function to
1568 ' cut down on your typing.
1569 ' ie. SetBoldDayState numYear 2004, numMonth:=1, day = 19
1570 Public Function SetBoldDayState(numYear As Long, numMonth As Long, day As Long, Optional ResetMonth As Boolean = False) '_
1571 '
1572 'Optional One As Boolean, Optional Two As Boolean, _
1573 'Optional Three As Boolean, Optional Four As Boolean, _
1574 'Optional Five As Boolean, Optional Six As Boolean, _
1575 'Optional Seven As Boolean, Optional Eight As Boolean, _
1576 'Optional Nine As Boolean, Optional Ten As Boolean, _
1577 'Optional Eleven As Boolean, Optional Twelve As Boolean, _
1578 'Optional Thirteen As Boolean, Optional Fourteen As Boolean, _
1579 'Optional Fifthteen As Boolean, Optional Sixteen As Boolean, _
1580 'Optional Seventeen As Boolean, Optional Eighteen As Boolean, _
1581 'Optional NineTeen As Boolean, Optional Twenty As Boolean, _
1582 'Optional TwentyOne As Boolean, Optional TwentyTwo As Boolean, _
1583 'Optional TwentyThree As Boolean, Optional TwentyFour As Boolean, _
1584 'Optional TwentyFive As Boolean, Optional TwentySix As Boolean, _
1585 'Optional TwentySeven As Boolean, Optional TwentyEight As Boolean, _
1586 'Optional TwentyNine As Boolean, Optional Thirty As Boolean, _
1587 'Optional ThirtyOne As Boolean, Optional ThirtyTwo As Boolean)
1588 '
1589
1590 '
1591 ' Init the month we are working with.
1592 ' Only clear this var if ResetMonth = TrUE
1593 If ResetMonth Then
1594 BoldDayStates(numYear, numMonth).lpMONTHDAYSTATE = 0
1595 End If
1596
1597 If day > 0 And day < 31 Then day = day - 1
1598 'BoldDayStates(numMonth) = BoldDays
1599 BoldDayStates(numYear, numMonth).lpMONTHDAYSTATE = BoldDayStates(numYear, numMonth).lpMONTHDAYSTATE Or 2 ^ day
1600 '
1601 'If One Then BoldDayStates(numMonth).lpMONTHDAYSTATE = 1 'BoldDayStates(numMonth).lpMONTHDAYSTATE Or 1
1602 'If Two Then BoldDayStates(numMonth).lpMONTHDAYSTATE = BoldDayStates(numMonth).lpMONTHDAYSTATE Or 2 ^ 1
1603 'If Three Then BoldDayStates(numMonth).lpMONTHDAYSTATE = BoldDayStates(numMonth).lpMONTHDAYSTATE Or 2 ^ 2
1604 'If Four Then BoldDayStates(numMonth).lpMONTHDAYSTATE = BoldDayStates(numMonth).lpMONTHDAYSTATE Or 2 ^ 3
1605 'If Five Then BoldDayStates(numMonth).lpMONTHDAYSTATE = BoldDayStates(numMonth).lpMONTHDAYSTATE Or 2 ^ 4
1606 'If Six Then BoldDayStates(numMonth).lpMONTHDAYSTATE = BoldDayStates(numMonth).lpMONTHDAYSTATE Or 2 ^ 5
1607 'If Seven Then BoldDayStates(numMonth).lpMONTHDAYSTATE = BoldDayStates(numMonth).lpMONTHDAYSTATE Or 2 ^ 6
1608 'If Eight Then BoldDayStates(numMonth).lpMONTHDAYSTATE = BoldDayStates(numMonth).lpMONTHDAYSTATE Or 2 ^ 7
1609 'If Nine Then BoldDayStates(numMonth).lpMONTHDAYSTATE = BoldDayStates(numMonth).lpMONTHDAYSTATE Or 2 ^ 8
1610 'If Ten Then BoldDayStates(numMonth).lpMONTHDAYSTATE = BoldDayStates(numMonth).lpMONTHDAYSTATE Or 2 ^ 9
1611 'If Eleven Then BoldDayStates(numMonth).lpMONTHDAYSTATE = BoldDayStates(numMonth).lpMONTHDAYSTATE Or 2 ^ 10
1612 'If Twelve Then BoldDayStates(numMonth).lpMONTHDAYSTATE = BoldDayStates(numMonth).lpMONTHDAYSTATE Or 2 ^ 11
1613 'If Thirteen Then BoldDayStates(numMonth).lpMONTHDAYSTATE = BoldDayStates(numMonth).lpMONTHDAYSTATE Or 2 ^ 12
1614 'If Fourteen Then BoldDayStates(numMonth).lpMONTHDAYSTATE = BoldDayStates(numMonth).lpMONTHDAYSTATE Or 2 ^ 13
1615 'If Fifthteen Then BoldDayStates(numMonth).lpMONTHDAYSTATE = BoldDayStates(numMonth).lpMONTHDAYSTATE Or 2 ^ 14
1616 'If Sixteen Then BoldDayStates(numMonth).lpMONTHDAYSTATE = BoldDayStates(numMonth).lpMONTHDAYSTATE Or 2 ^ 15
1617 'If Seventeen Then BoldDayStates(numMonth).lpMONTHDAYSTATE = BoldDayStates(numMonth).lpMONTHDAYSTATE Or 2 ^ 16
1618 'If Eighteen Then BoldDayStates(numMonth).lpMONTHDAYSTATE = BoldDayStates(numMonth).lpMONTHDAYSTATE Or 2 ^ 17
1619 'If NineTeen Then BoldDayStates(numMonth).lpMONTHDAYSTATE = BoldDayStates(numMonth).lpMONTHDAYSTATE Or 2 ^ 18
1620 '
1621 'If Twenty Then BoldDayStates(numMonth).lpMONTHDAYSTATE = BoldDayStates(numMonth).lpMONTHDAYSTATE Or 2 ^ 19
1622 'If TwentyOne Then BoldDayStates(numMonth).lpMONTHDAYSTATE = BoldDayStates(numMonth).lpMONTHDAYSTATE Or 2 ^ 20
1623 'If TwentyTwo Then BoldDayStates(numMonth).lpMONTHDAYSTATE = BoldDayStates(numMonth).lpMONTHDAYSTATE Or 2 ^ 21
1624 'If TwentyThree Then BoldDayStates(numMonth).lpMONTHDAYSTATE = BoldDayStates(numMonth).lpMONTHDAYSTATE Or 2 ^ 22
1625 'If TwentyFour Then BoldDayStates(numMonth).lpMONTHDAYSTATE = BoldDayStates(numMonth).lpMONTHDAYSTATE Or 2 ^ 23
1626 'If TwentyFive Then BoldDayStates(numMonth).lpMONTHDAYSTATE = BoldDayStates(numMonth).lpMONTHDAYSTATE Or 2 ^ 24
1627 'If TwentySix Then BoldDayStates(numMonth).lpMONTHDAYSTATE = BoldDayStates(numMonth).lpMONTHDAYSTATE Or 2 ^ 25
1628 'If TwentySeven Then BoldDayStates(numMonth).lpMONTHDAYSTATE = BoldDayStates(numMonth).lpMONTHDAYSTATE Or 2 ^ 26
1629 'If TwentyEight Then BoldDayStates(numMonth).lpMONTHDAYSTATE = BoldDayStates(numMonth).lpMONTHDAYSTATE Or 2 ^ 27
1630 'If TwentyNine Then BoldDayStates(numMonth).lpMONTHDAYSTATE = BoldDayStates(numMonth).lpMONTHDAYSTATE Or 2 ^ 28
1631 '
1632 'If Thirty Then BoldDayStates(numMonth).lpMONTHDAYSTATE = BoldDayStates(numMonth).lpMONTHDAYSTATE Or 2 ^ 29
1633 'If ThirtyOne Then BoldDayStates(numMonth).lpMONTHDAYSTATE = BoldDayStates(numMonth).lpMONTHDAYSTATE Or 2 ^ 30
1634 '
1635 End Function
1636
1637
1638 Private Sub Class_Initialize()
1639 ' Number of pixels to leave at the Top of the form before we
1640 ' begin to draw our Calendar. This leaves room for any
1641 ' controls we have at the top of the form.
1642 Me.CalendarYOffset = 20
1643
1644 ' Default Number of Columns and Rows
1645 ' 6 month display
1646 'Me.MonthColumns = 3
1647 'Me.MonthRows = 2
1648 ' Check and see if Custom Prop exists
1649 blRet = GetProperty("MonthColumns", varTemp)
1650 If blRet Then
1651 m_MonthColumns = varTemp
1652 Else
1653 m_MonthColumns = 3
1654 End If
1655
1656 blRet = GetProperty("MonthRows", varTemp)
1657 If blRet Then
1658 m_MonthRows = varTemp
1659 Else
1660 m_MonthRows = 2
1661 End If
1662
1663
1664 ' Default Font stuff
1665 ' Check and see if Custom Prop exists
1666 blRet = GetProperty("FontName", varTemp)
1667 If blRet Then
1668 Me.FontName = varTemp
1669 Else
1670 Me.FontName = "Arial"
1671 End If
1672
1673 blRet = GetProperty("FontSize", varTemp)
1674 If blRet Then
1675 Me.FontSize = varTemp
1676 Else
1677 Me.FontSize = 8
1678 End If
1679
1680 hFontPrevious = 0
1681
1682 blRet = GetProperty("MCS_MULTISELECT", varTemp)
1683 If blRet Then
1684 MultiSelect = varTemp
1685 Else
1686 ' MultiSelect to start
1687 MultiSelect = MCS_MULTISELECT '0 to Turn Off
1688 End If
1689
1690 blRet = GetProperty("MCS_WEEKNUMBERS", varTemp)
1691 If blRet Then
1692 ShowWeekNumbers = varTemp
1693 Else
1694 ' MultiSelect to start
1695 ShowWeekNumbers = MCS_WEEKNUMBERS '0 to Turn Off
1696 End If
1697
1698 blRet = GetProperty("NoToday", varTemp)
1699 If blRet Then
1700 m_NoToday = varTemp
1701 Else
1702 ' Show Today is turned off
1703 m_NoToday = MCS_NOTODAY '0 to Turn Off
1704 End If
1705
1706 blRet = GetProperty("NoTodayCircle", varTemp)
1707 If blRet Then
1708 m_NoTodayCircle = varTemp
1709 Else
1710 ' Show Today is turned off
1711 m_NoToday = MCS_NOTODAYCIRCLE '0 to Turn Off
1712 End If
1713
1714
1715 blRet = GetProperty("WindowLocation", varTemp)
1716 If blRet Then
1717 m_WindowLocation = varTemp
1718 Else
1719 ' Window Location
1720 m_WindowLocation = 0
1721 End If
1722
1723 ' June 7, 2003
1724 ' Fixing PositionAtCursor logic
1725 If varTemp = 0 Then
1726 ' Init
1727 Me.PositionAtCursor = True
1728 Else
1729 Me.PositionAtCursor = False
1730 End If
1731
1732 ' Only load if PositionAtCursor is False
1733 If Not Me.PositionAtCursor Then
1734 blRet = GetProperty("Cursorx", varTemp)
1735 If blRet Then
1736 m_cursorX = varTemp
1737 Else
1738 ' Leave Alone!
1739 m_cursorX = 0
1740 End If
1741 End If
1742
1743 'Only load if PositionAtCursor is False
1744 If Not Me.PositionAtCursor Then
1745 blRet = GetProperty("CursorY", varTemp)
1746 If blRet Then
1747 m_cursorY = varTemp
1748 Else
1749 ' Get current Cursor Position!
1750 'Dim pt As POINTAPI
1751 'lngRet = GetCursorPos(pt)
1752 ' m_cursorXinit = pt.x
1753 ' m_cursorYinit = pt.y
1754 ' m_cursorX = pt.x
1755 'm_cursorY = pt.y
1756 m_cursorY = 0
1757 End If
1758 End If
1759
1760 ' Check our Color props.
1761 ' Set var to NotAColor constant if prop doesn't exist
1762 blRet = GetProperty("BackColor", varTemp)
1763 If blRet Then
1764 m_BackColor = varTemp
1765 Else
1766 ' Set var to nonexistent color
1767 m_BackColor = NotAColor
1768 End If
1769
1770 blRet = GetProperty("MonthBackColor", varTemp)
1771 If blRet Then
1772 m_MonthBackColor = varTemp
1773 Else
1774 ' Set var to nonexistent color
1775 m_MonthBackColor = NotAColor
1776 End If
1777
1778
1779 blRet = GetProperty("ForeColor", varTemp)
1780 If blRet Then
1781 m_ForeColor = varTemp
1782 Else
1783 ' Set var to nonexistent color
1784 m_ForeColor = NotAColor
1785 End If
1786
1787 blRet = GetProperty("TitleBackColor", varTemp)
1788 If blRet Then
1789 m_TitleBackColor = varTemp
1790 Else
1791 ' Set var to nonexistent color
1792 m_TitleBackColor = NotAColor
1793 End If
1794
1795 blRet = GetProperty("TitleForeColor", varTemp)
1796 If blRet Then
1797 m_TitleForeColor = varTemp
1798 Else
1799 ' Set var to nonexistent color
1800 m_TitleForeColor = NotAColor
1801 End If
1802
1803 blRet = GetProperty("TrailingForeColor", varTemp)
1804 If blRet Then
1805 m_TrailingForeColor = varTemp
1806 Else
1807 ' Set var to nonexistent color
1808 m_TrailingForeColor = NotAColor
1809 End If
1810
1811 blRet = GetProperty("OneClick", varTemp)
1812 If blRet Then
1813 m_oneClick = varTemp
1814 Else
1815 ' Set var to nonexistent color
1816 m_oneClick = True
1817 End If
1818
1819 ' Max number of days user can select in a continuous range
1820 m_MaxSelectRangeofDays = 31
1821 ' To select a Range of Dates add code like below
1822 'm_EndDate = #2/27/00#
1823 'm_StartDate = #2/21/00#
1824
1825 ' Set DayState
1826 ' For this example we will set one day per month
1827 ' corresponding to the Month number
1828 Erase BoldDayStates
1829 ' Here is an example of how to Set the BoldDayState prop for Jan 19,2004.
1830 ' ie. SetBoldDayState numYear 2004, numMonth:=1, day = 19
1831
1832 End Sub
1833
1834 Public Sub Class_Terminate()
1835 ' Cleanup after ourselves.
1836 On Error Resume Next
1837
1838 'Debug.Print "start ClsMonthCalendat Terminated:" & Now
1839 ' March 05 Debug
1840 ' Not getting a clean exit when user Closes
1841 ' Calling Form with Calendar still Open
1842 If m_hWndDTP <> 0 Then
1843 lngRet = apiDestroyWindow(m_hWndDTP)
1844 'Debug.Print "Destroyed m_hWndDTP:" & lngRet
1845 End If
1846
1847 ' Wait until Window is definately gone!
1848 lngRet = apiDestroyWindow(Me.m_Hwnd)
1849 'Debug.Print "Destroyed Me.m_Hwnd:" & lngRet
1850 DoEvents
1851
1852 Dim hWndTemp As Long
1853
1854 ' If this window already exists then exit!
1855 hWndTemp = 1
1856 Do While hWndTemp <> 0
1857 hWndTemp = FindWindow(CLASSNAME, TITLE)
1858 'Debug.Print "MonthCal Hwnd -hWndTemp:" & hWndTemp
1859 Loop
1860
1861 ' See if we have a new Font handle hanging around.
1862 If hFontPrevious <> 0 Then
1863 'Debug.Print "deleting FOnt"
1864 DeleteObject hFontPrevious
1865 End If
1866
1867 'Debug.Print "End ClsMonthCalendar Terminated:" & Now
1868 End Sub
1869
1870 ' *** CODE END ***
1871
1872
1873 Private Function GetProperty(ByVal strPropName As String, ByRef strPropValue As Variant) As Boolean
1874 ' Changed strPropValue as String to as Variant
1875
1876 Const cProcedureName As String = "GetProperty"
1877 On Error GoTo Err_Handler
1878
1879 Dim sDefault As String
1880
1881 Select Case strPropName
1882
1883 Case "BackColor"
1884 sDefault = vbWhite
1885
1886 Case "FontName"
1887 sDefault = "Arial"
1888
1889 Case "FontSize"
1890 sDefault = 8
1891
1892 Case "ForeColor"
1893 sDefault = GetSysColor(COLOR_WINDOWTEXT)
1894
1895 Case "MonthBackColor"
1896 sDefault = vbWhite
1897
1898 Case "MonthColumns"
1899 sDefault = 1
1900
1901 Case MultiSelect
1902 sDefault = "0" 'false
1903
1904 Case "NoToday"
1905 sDefault = MCS_NOTODAY
1906
1907 Case "NoTodayCircle"
1908 sDefault = MCS_NOTODAYCIRCLE
1909
1910 Case "OneClick"
1911 sDefault = "1" ' true
1912
1913 Case "MCS_WEEKNUMBERS"
1914 sDefault = MCS_WEEKNUMBERS
1915
1916 Case "MonthRows"
1917 sDefault = 1
1918
1919 Case "TitleBackColor"
1920 sDefault = GetSysColor(COLOR_ACTIVECAPTION)
1921
1922 Case "TitleForeColor"
1923 sDefault = vbWhite 'GetSysColor() 'vbTitleBarText
1924
1925 Case "TrailingForeColor"
1926 sDefault = GetSysColor(COLOR_GRAYTEXT) ' apiSendMessage(m_hWndDTP, MCM_GETCOLOR, MCSC_TRAILINGTEXT, 0&)
1927
1928 Case "WindowLocation"
1929 ' Position Window according to users Menu selections
1930 ' a) 0 -Pop at cursor location when user activates Calendar
1931 ' b) 1 -Where they manually move/leave it at
1932 ' c) 2 -Centered in Access App Window
1933 ' d) 3 -Centered on entire screen
1934 ' d) 4 -Top Left Corner
1935 sDefault = 0
1936
1937
1938
1939 Case Else
1940 ' not possible...I hope!
1941 sDefault = ""
1942 GetProperty = False
1943 Exit Function
1944
1945 End Select
1946
1947 strPropValue = GetSetting("MonthCalendarSL", "CalendarProperties", strPropName, sDefault)
1948 GetProperty = True
1949
1950 Exit_Sub:
1951 On Error GoTo 0
1952 Exit Function
1953 Err_Handler:
1954 Resume Exit_Sub
1955 End Function
1956
1957
1958 Sub SetProperty(ByVal strPropName As String, ByVal varPropType As Variant, _
1959 ByVal varPropValue As Variant)
1960 Const cProcedureName As String = "SetProperty"
1961 On Error GoTo Err_Handler
1962
1963 SaveSetting "MonthCalendarSL", "CalendarProperties", strPropName, varPropValue
1964
1965 Exit_Sub:
1966 On Error GoTo 0
1967 Exit Sub
1968 Err_Handler:
1969 Resume Exit_Sub
1970 End Sub
1971
1972
1973
1974 'Private Function GetProperty(ByVal strPropName As String, ByRef strPropValue As Variant) As Boolean
1975 '' Changed strPropValue as String to as Variant
1976 '
1977 'Const cProcedureName As String = "GetProperty"
1978 'On Error GoTo Err_Handler
1979 'Dim db As DAO.Database
1980 '
1981 ' Set db = CurrentDb
1982 ' strPropValue = db.Properties(strPropName)
1983 ' GetProperty = True
1984 '
1985 'Exit_Sub:
1986 ' On Error GoTo 0
1987 ' Set db = Nothing
1988 ' Exit Function
1989 'Err_Handler:
1990 ' GetProperty = False
1991 ' Select Case Err
1992 ' Case cerrPropertyNotFound
1993 ' Case Else
1994 ' ' Call LogError(Err.Number, Err.Description, cModuleName & cProcedureName)
1995 ' End Select
1996 ' Resume Exit_Sub
1997 'End Function
1998
1999
2000
2001
2002
2003 'Sub SetProperty(ByVal strPropName As String, ByVal varPropType As Variant, _
2004 ' ByVal varPropValue As Variant)
2005 'Const cProcedureName As String = "SetProperty"
2006 'On Error GoTo Err_Handler
2007 'Dim db As DAO.Database
2008 'Dim prp As DAO.Property
2009 '
2010 ' Set db = DBEngine(0)(0)
2011 ' db.Properties(strPropName).Value = varPropValue
2012 '
2013 'Exit_Sub:
2014 ' On Error GoTo 0
2015 ' Set prp = Nothing
2016 ' Set db = Nothing
2017 ' Exit Sub
2018 'Err_Handler:
2019 ' Select Case Err
2020 ' Case cerrPropertyNotFound
2021 ' Set prp = db.CreateProperty(strPropName, varPropType, varPropValue)
2022 ' db.Properties.Append prp
2023 ' Case Else
2024 ' 'Call LogError(Err.Number, Err.Description, cModuleName & cProcedureName)
2025 ' End Select
2026 ' Resume Exit_Sub
2027 '
2028 'End Sub
2029
2030
2031
2032
2033 'typedef DWORD MONTHDAYSTATE, FAR * LPMONTHDAYSTATE;
2034 '// BOOL MonthCal_SetDayState(HWND hmc, int cbds, DAYSTATE *rgds)
2035 '// cbds is the count of DAYSTATE items in rgds and it must be equal
2036 '// to the value returned from MonthCal_GetMonthRange(hmc, GMR_DAYSTATE, NULL)
2037 '// This sets the DAYSTATE bits for each month (grayed and non-grayed
2038 '// days) displayed in the calendar. The first bit in a month's DAYSTATE
2039 '// corresponts to bolding day 1, the second bit affects day 2, etc.
2040 '#define MCM_SETDAYSTATE (MCM_FIRST + 8)
2041 '#define MonthCal_SetDayState(hmc, cbds, rgds)
2042 'SNDMSG(hmc, MCM_SETDAYSTATE, (WPARAM)(cbds), (LPARAM)(rgds))
2043
2044
2045
2046 '
2047 ' lngStyle = GetWindowLong(m_hWndDTP, GWL_STYLE)
2048 ' 'We can Set/Reset these styles with recreating the Control:
2049 ' lngStyle = lngStyle And Not (MCS_WEEKNUMBERS Or MCS_NOTODAY Or MCS_NOTODAYCIRCLE)
2050 ' If m_WeekNumbers Then lngStyle = lngStyle Or MCS_WEEKNUMBERS
2051 ' If Not m_ShowToday Then lngStyle = lngStyle Or MCS_NOTODAY
2052 ' If Not m_TodayCircle Then lngStyle = lngStyle Or MCS_NOTODAYCIRCLE
2053 ' SetWindowLong m_hWndDTP, GWL_STYLE, lngStyle
2054 '
2055
2056
2057 ' ************************
2058 ' DEBUG GPF
2059 ' ************************
2060 'Public Property Get xx() As Long
2061 'xx = 1
2062 'End Property
2063
2064
2065 Public Function IsCalendar() As Boolean
2066 Dim hWndTemp As Long
2067
2068 ' If this window already exists then exit!
2069 hWndTemp = 0
2070 hWndTemp = FindWindow(CLASSNAME, TITLE)
2071 If hWndTemp <> 0 Then
2072 IsCalendar = True
2073 Call Beep(12000, 1000)
2074 Else
2075 IsCalendar = False
2076 End If
2077 End Function
