1 ''' // **********************************************************************************
   2 ''' // Date Picker Main Module
   3 ''' // **********************************************************************************
   4 
   5 
   6 'DEVELOPED AND TESTED UNDER MICROSOFT ACCESS 97 and Access2K
   7 '
   8 'Copyright: Stephen Lebans - Lebans Holdings 1999 Ltd.
   9 '           Please feel free to use this code within your own
  10 '           projects whether they are private or commercial applications
  11 '           without obligation.
  12 '           This code may not be resold by itself or as part of a collection.
  13 '
  14 'Name:      modCalendar
  15 '
  16 'Version:   2.05
  17 '
  18 'Purpose:
  19 '           Create a Window with a Window Procedure to house the
  20 '           Month Calendar control. Further provide a Menu interface
  21 '           to allow the user to modify the Calendar's properties.
  22 '           The Window procedure must reside in a standard Code module.
  23 '
  24 'Author:    Stephen Lebans
  25 '
  26 'Email:     Stephen@lebans.com
  27 '
  28 'Web Site:  www.lebans.com
  29 '
  30 'Date:      Dec 09, 2004
  31 '
  32 'Credits:   Based on code by:
  33 '           Ray Mercer - Window Creation & Messaging in VB
  34 '           Ken Getz & Michael Kaplan - AddrOf
  35 '           Charles Petzold - Window Creation and Message loops
  36 '           Dev Ashish - AddrOf implementation - Access Version checking
  37 '           Pedro Gil - Initial framework and props
  38 '           MSDN KB
  39 '
  40 'BUGS:  Fixed the bug that appears as a result of  Access
  41 '           is caching the WinProc.
  42 '           Added a call to UnregisterClass to resolve the issue.
  43 '
  44 'What's Missing:
  45 '           You tell me!
  46 '
  47 '           Proper Error handling.
  48 '
  49 'How it Works:
  50 '           The Month Calendar is created directly with the
  51 '           API's contained in the Common Controls DLL. In this manner we bypass
  52 '           the DatePicker ActiveX control, which is simply a wrapper for these
  53 '           calls anyway. This removes any problems from distribution and
  54 '           especially version issues of using the ActiveX control.
  55 '
  56 ' This is the 10th major release.
  57 
  58 ' To exit from the Window Procedure,
  59 ' thereby closing the MonthCalendar Control,
  60 ' you can either:
  61 '1) Press the Escape Key
  62 '2) Click on the Window's Close Button(x)
  63 '3) Double Click or Single Click the Left Mouse Button on a Date
  64 '   It depends on your settings for the Calendar Properties
  65 
  66 ' ****************************************************
  67 '
  68 '               WARNING
  69 '
  70 ' If you place a Breakpoint within the Window Procedure
  71 ' you will cause a GPF!
  72 '
  73 ' ****************************************************
  74 
  75 ''' // **********************************************************************************
  76 ''' // Ver.: 3.0.0
  77 ''' // (c) 2009; digital-ecom GmbH
  78 ''' // Adapted to MS Excel incl. Excel 2000
  79 
  80 ''' // Extension:
  81 ''' // 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.
  82 ''' // digital-ecom GmbH, 22.05.2009
  83 
  84 ''' // Bug Fixing:
  85 ''' // When closing the dialog, especially on cancel:
  86 ''' // First activate Excel Window, then close Calendar Ctrl - this assures we do not jump to other applications when simply closing
  87 ''' // the calendar Ctrl and it does prevent screen flickering.
  88 
  89 ''' // Made the control capable to be used with modeless user forms.
  90 ''' // digital-ecom GmbH, May 2009
  91 
  92 ''' // Made code readable ... <sigh />
  93 ''' // Added usage of just one constant for Classname and Title
  94 
  95 ''' // Note: All original comments were used where possible. Our comments are introduced by ''' // always.
  96 ''' // **********************************************************************************
  97 
  98 Option Explicit
  99 Option Private Module
 100 
 101 Type RECT
 102     Left As Long
 103     Top As Long
 104     Right As Long
 105     Bottom As Long
 106 End Type
 107 
 108 Type WNDCLASSEX
 109     cbSize As Long
 110     Style As Long
 111     lpfnWndProc As Long
 112     cbClsExtra As Long
 113     cbWndExtra As Long
 114     hInstance As Long
 115     hIcon As Long
 116     hCursor As Long
 117     hbrBackground As Long
 118     lpszMenuName As String
 119     lpszClassName As String
 120     hIconSm As Long
 121 End Type
 122 
 123 Type POINTAPI
 124     X As Long
 125     y As Long
 126 End Type
 127 
 128 Type msg
 129     hwnd As Long
 130     message As Long
 131     wParam As Long
 132     lParam As Long
 133     time As Long
 134     pt As POINTAPI
 135 End Type
 136 
 137 Type PAINTSTRUCT
 138     hdc As Long
 139     fErase As Long
 140     rcPaint As RECT
 141     fRestore As Long
 142     fIncUpdate As Long
 143     rgbReserved(32) As Byte
 144 End Type
 145 
 146 '// bit-packed array of "bold" info for a month
 147 '// if a bit is on, that day is drawn bold
 148 Private Type MONTHDAYSTATE
 149     lpMONTHDAYSTATE As Long
 150     ' SHould really be array of 4 bytes because
 151     ' of VB's Signed datatypes
 152 End Type
 153 
 154 ' Control Message Header
 155 Private Type NMHDR
 156     hwndFrom As Long
 157     idfrom As Long
 158     code As Long 'Integer
 159 End Type
 160 
 161 'The actual Date/Time values are stored this way
 162 Private Type SYSTEMTIME
 163     wYear As Integer
 164     wMonth As Integer
 165     wDayOfWeek As Integer
 166     wDay As Integer
 167     wHour As Integer
 168     wMinute As Integer
 169     wSecond As Integer
 170     wMilliseconds As Integer
 171 End Type
 172 
 173 ' MonthCalendar SelectChange
 174 Private Type NMSELCHANGE
 175     nm As NMHDR
 176     stSelStart As SYSTEMTIME
 177     stSelEnd As SYSTEMTIME
 178 End Type
 179 
 180 ' DayState Header
 181 Private Type NMDAYSTATE
 182     nmhd As NMHDR ' // this must be first, so we don't break WM_NOTIFY
 183     stStart As SYSTEMTIME
 184     cDayState As Long ' F0r ease of use always specify 12 months of data
 185     prgDayState As Long 'MONTHDAYSTATE '; // points to cDayState MONTHDAYSTATEs
 186 End Type
 187 
 188 Private Type MCHITTESTINFO
 189     cbSize As Long
 190     pt As POINTAPI
 191     uHit As Long
 192     st As SYSTEMTIME
 193 End Type
 194 
 195 
 196 ' ********************************
 197 ' VB6 RUNTIMES must be present to resolve this call
 198 ' Returns address of the address of the associated SafeArray descriptor
 199 Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (ptr() As Any) As Long
 200 '*********************************************************************
 201 
 202 Private Declare Function GetActiveWindow Lib "user32" () As Long
 203 
 204 Private Declare Function GetDoubleClickTime Lib "user32" () As Long
 205 
 206 Private Declare Function GetMessageTime Lib "user32" () As Long
 207 
 208 Private Declare Function SetProp Lib "user32" Alias "SetPropA" _
 209                                         (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
 210 
 211 Private Declare Function GetProp Lib "user32" Alias "GetPropA" _
 212                                         (ByVal hwnd As Long, ByVal lpString As String) As Long
 213 
 214 Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" _
 215                                         (ByVal hwnd As Long, ByVal lpString As String) As Long
 216 
 217 Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" _
 218                                 (Destination As Any, Source As Any, ByVal Length As Long)
 219 
 220 Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" _
 221                                         (ByVal hwnd As Long, ByVal lpString As String) As Long
 222 
 223 Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" _
 224                                         (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
 225 
 226 Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" _
 227                                         (ByVal hwnd As Long) As Long
 228 
 229 Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
 230 
 231  Private Declare Function apiSendMessage Lib "user32" Alias "SendMessageA" _
 232                                         (ByVal hwnd As Long, _
 233                                         ByVal wMsg As Long, _
 234                                         ByVal wParam As Long, _
 235                                         lParam As Any) As Long
 236 
 237 Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" _
 238                             (ByVal dwExStyle As Long, _
 239                             ByVal lpClassName As String, _
 240                             ByVal lpWindowName As String, _
 241                             ByVal dwStyle As Long, _
 242                             ByVal X As Long, _
 243                             ByVal y As Long, _
 244                             ByVal nWidth As Long, _
 245                             ByVal nHeight As Long, _
 246                             ByVal hWndParent As Long, _
 247                             ByVal hMenu As Long, _
 248                             ByVal hInstance As Long, _
 249                             lpParam As Any) As Long
 250 
 251 Private Declare Function ClientToScreen Lib "user32" _
 252                                         (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
 253 
 254 Private Declare Function ScreenToClient Lib "user32" _
 255                                         (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
 256 
 257 Private Declare Function PostMessageString Lib "user32" Alias "PostMessageA" _
 258                                         (ByVal hwnd As Long, ByVal wMsg As Long, _
 259                                         ByVal wParam As Long, ByVal lParam As String) As Long
 260 
 261 Private Declare Function InsertMenu Lib "user32" Alias "InsertMenuA" _
 262                                         (ByVal hMenu As Long, ByVal nPosition As Long, _
 263                                         ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Any) As Long
 264 
 265 Private Declare Function CreatePopupMenu Lib "user32" () As Long
 266 
 267 Private Declare Function CreateMenu Lib "user32" () As Long
 268 
 269 Private Declare Function CheckMenuItem Lib "user32" _
 270                                         (ByVal hMenu As Long, ByVal wIDCheckItem As Long, ByVal wCheck As Long) As Long
 271 
 272 Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
 273                                         (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
 274 
 275 Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
 276                                         (ByVal hwnd As Long, ByVal nIndex As Long) As Long
 277 
 278 Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" _
 279                                         (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, _
 280                                         ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
 281 
 282 Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
 283 
 284 Private Declare Function LoadIcon Lib "user32" Alias "LoadIconA" _
 285                                         (ByVal hInstance As Long, ByVal lpIconName As String) As Long
 286 
 287 Private Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" _
 288                                         (ByVal hInstance As Long, ByVal lpCursorName As String) As Long
 289 
 290 Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
 291 
 292 Private Declare Function RegisterClassEx Lib "user32" Alias "RegisterClassExA" _
 293                                         (pcWndClassEx As WNDCLASSEX) As Integer
 294 
 295 Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
 296 
 297 Private Declare Function UpdateWindow Lib "user32" (ByVal hwnd As Long) As Long
 298 
 299 Private Declare Function SetFocus Lib "user32" (ByVal hwnd As Long) As Long
 300 
 301 Declare Function PostMessage Lib "user32" Alias "PostMessageA" _
 302                             (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
 303 
 304 Private Declare Function DefWindowProc Lib "user32" Alias "DefWindowProcA" _
 305                                         (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
 306 
 307 Private Declare Function GetMessage Lib "user32" Alias "GetMessageA" _
 308                                         (lpMsg As msg, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long
 309 
 310 Private Declare Function TranslateMessage Lib "user32" (lpMsg As msg) As Long
 311 
 312 Private Declare Function DispatchMessage Lib "user32" Alias "DispatchMessageA" _
 313                                         (lpMsg As msg) As Long
 314 
 315 Private Declare Sub PostQuitMessage Lib "user32" (ByVal nExitCode As Long)
 316 
 317 Private Declare Function BeginPaint Lib "user32" _
 318                                         (ByVal hwnd As Long, lpPaint As PAINTSTRUCT) As Long
 319 
 320 Private Declare Function EndPaint Lib "user32" _
 321                                         (ByVal hwnd As Long, lpPaint As PAINTSTRUCT) As Long
 322 
 323 Private Declare Function GetClientRect Lib "user32" _
 324                                         (ByVal hwnd As Long, lpRect As RECT) As Long
 325 
 326 Private Declare Function GetWindowRect Lib "user32" _
 327                                         (ByVal hwnd As Long, lpRect As RECT) As Long
 328 
 329 Private Declare Function DrawText Lib "user32" Alias "DrawTextA" _
 330                                         (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, _
 331                                         lpRect As RECT, ByVal wFormat As Long) As Long
 332 
 333 Private Declare Function apiGetWindowLong Lib "user32" _
 334                                         Alias "GetWindowLongA" _
 335                                         (ByVal hwnd As Long, _
 336                                         ByVal nIndex As Long) As Long
 337 
 338 Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
 339                                         (ByVal lpClassName As String, _
 340                                         ByVal lpWindowName As String) As Long
 341 
 342 Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
 343                                         (ByVal hWnd1 As Long, ByVal hWnd2 As Long, _
 344                                         ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
 345 
 346 Private Declare Function UnregisterClass Lib "user32" Alias "UnregisterClassA" _
 347                                         (ByVal lpClassName As String, _
 348                                         ByVal hInstance As Long) As Long
 349 
 350 Private Declare Function GetDesktopWindow Lib "user32" () As Long
 351 
 352 Private Declare Function MessageBeep Lib "user32" Alias "BeepA" (ByVal wType As Long) As Long
 353 
 354 Private Declare Function Beep Lib "kernel32" _
 355                                         (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long
 356 
 357 ' Enable/Disable Main Access Window
 358 Private Declare Function EnableWindow Lib "user32" _
 359                                         (ByVal hwnd As Long, ByVal fEnable As Long) As Long
 360 
 361 Private Declare Function IsWindowEnabled Lib "user32" _
 362                                         (ByVal hwnd As Long) As Long
 363 
 364 Private Declare Function SetForegroundWindow Lib "user32" _
 365                                         (ByVal hwnd As Long) As Long
 366 
 367 Private Declare Function LockWindowUpdate Lib "user32" _
 368                                         (ByVal hWndLock As Long) As Long
 369 
 370 Private Declare Function SetCapture Lib "user32" _
 371                                         (ByVal hwnd As Long) As Long
 372 
 373 Private Declare Function ReleaseCapture Lib "user32" () As Long
 374 
 375 Private Declare Function GetCursorPos Lib "user32" _
 376                                         (lpPoint As POINTAPI) As Long
 377 
 378 ' Button Control Styles
 379 Private Const BS_PUSHBUTTON = &H0&
 380 Private Const BS_DEFPUSHBUTTON = &H1&
 381 Private Const BS_CHECKBOX = &H2&
 382 Private Const BS_AUTOCHECKBOX = &H3&
 383 Private Const BS_RADIOBUTTON = &H4&
 384 Private Const BS_3STATE = &H5&
 385 Private Const BS_AUTO3STATE = &H6&
 386 Private Const BS_GROUPBOX = &H7&
 387 Private Const BS_USERBUTTON = &H8&
 388 Private Const BS_AUTORADIOBUTTON = &H9&
 389 Private Const BS_OWNERDRAW = &HB&
 390 Private Const BS_LEFTTEXT = &H20&
 391 
 392 ' User Button Notification Codes
 393 Private Const BN_CLICKED = 0
 394 Private Const BN_PAINT = 1
 395 Private Const BN_HILITE = 2
 396 Private Const BN_UNHILITE = 3
 397 Private Const BN_DISABLE = 4
 398 Private Const BN_DOUBLECLICKED = 5
 399 
 400 ' Button Control Messages
 401 Private Const BM_GETCHECK = &HF0
 402 Private Const BM_SETCHECK = &HF1
 403 Private Const BM_GETSTATE = &HF2
 404 Private Const BM_SETSTATE = &HF3
 405 Private Const BM_SETSTYLE = &HF4
 406 
 407 ' CONSTANTS
 408 Private Const WM_KEYFIRST = &H100
 409 Private Const WM_KEYDOWN = &H100
 410 Private Const WM_KEYUP = &H101
 411 Private Const WM_CHAR = &H102
 412 Private Const WM_DEADCHAR = &H103
 413 Private Const WM_SYSKEYDOWN = &H104
 414 Private Const WM_SYSKEYUP = &H105
 415 Private Const WM_SYSCHAR = &H106
 416 
 417 ' GetWindowLong  / SetWindowLong
 418 Private Const GWL_HINSTANCE = (-6)
 419 Private Const GWL_STYLE = (-16)
 420 
 421 Private Const MF_ENABLED = &H0&
 422 Private Const WS_VISIBLE As Long = &H10000000
 423 Private Const WS_VSCROLL As Long = &H200000
 424 Private Const WS_TABSTOP As Long = &H10000
 425 Private Const WS_THICKFRAME As Long = &H40000
 426 Private Const WS_MAXIMIZE As Long = &H1000000
 427 Private Const WS_MAXIMIZEBOX As Long = &H10000
 428 Private Const WS_MINIMIZE As Long = &H20000000
 429 Private Const WS_MINIMIZEBOX As Long = &H20000
 430 Private Const WS_SYSMENU As Long = &H80000
 431 Private Const WS_BORDER As Long = &H800000
 432 Private Const WS_CAPTION As Long = &HC00000
 433 Private Const WS_CHILD As Long = &H40000000
 434 Private Const WS_CHILDWINDOW As Long = (WS_CHILD)
 435 Private Const WS_CLIPCHILDREN As Long = &H2000000
 436 Private Const WS_CLIPSIBLINGS As Long = &H4000000
 437 Private Const WS_DISABLED As Long = &H8000000
 438 Private Const WS_DLGFRAME As Long = &H400000
 439 Private Const WS_EX_ACCEPTFILES As Long = &H10&
 440 Private Const WS_EX_DLGMODALFRAME As Long = &H1&
 441 Private Const WS_EX_NOPARENTNOTIFY As Long = &H4&
 442 Private Const WS_EX_TOPMOST As Long = &H8&
 443 Private Const WS_EX_TRANSPARENT As Long = &H20&
 444 Private Const WS_GROUP As Long = &H20000
 445 Private Const WS_HSCROLL As Long = &H100000
 446 Private Const WS_ICONIC As Long = WS_MINIMIZE
 447 Private Const WS_OVERLAPPED As Long = &H0&
 448 Private Const WS_OVERLAPPEDWINDOW As Long = (WS_OVERLAPPED Or WS_CAPTION Or WS_SYSMENU Or WS_THICKFRAME Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX)
 449 Private Const WS_POPUP As Long = &H80000000
 450 Private Const WS_POPUPWINDOW As Long = (WS_POPUP Or WS_BORDER Or WS_SYSMENU)
 451 Private Const WS_SIZEBOX As Long = WS_THICKFRAME
 452 Private Const WS_TILED As Long = WS_OVERLAPPED
 453 Private Const WS_TILEDWINDOW As Long = WS_OVERLAPPEDWINDOW
 454 Private Const CW_USEDEFAULT As Long = &H80000000
 455 Private Const CS_HREDRAW As Long = &H2
 456 Private Const CS_VREDRAW As Long = &H1
 457 Private Const IDI_APPLICATION As Long = 32512&
 458 Private Const IDC_ARROW As Long = 32512&
 459 Private Const WHITE_BRUSH As Integer = 0
 460 Private Const BLACK_BRUSH As Integer = 4
 461 
 462 Private Const WM_CLOSE As Long = &H10
 463 Private Const WM_DESTROY As Long = &H2
 464 Private Const WM_PAINT As Long = &HF
 465 Private Const WM_NOTIFY = &H4E
 466 Private Const WM_PARENTNOTIFY = &H210
 467 Private Const WM_SETTEXT = &HC
 468 Private Const WM_INITMENU = &H116
 469 Private Const WM_INITMENUPOPUP = &H117
 470 Private Const WM_MENUSELECT = &H11F
 471 Private Const WM_MENUCHAR = &H120
 472 Private Const WM_ENTERIDLE = &H121
 473 
 474 
 475 
 476 ' ShowWindow() Commands
 477 Private Const SW_HIDE = 0
 478 Private Const SW_SHOWNORMAL = 1
 479 Private Const SW_NORMAL = 1
 480 Private Const SW_SHOWMINIMIZED = 2
 481 Private Const SW_SHOWMAXIMIZED = 3
 482 Private Const SW_MAXIMIZE = 3
 483 Private Const SW_SHOWNOACTIVATE = 4
 484 Private Const SW_SHOW = 5
 485 Private Const SW_MINIMIZE = 6
 486 Private Const SW_SHOWMINNOACTIVE = 7
 487 Private Const SW_SHOWNA = 8
 488 Private Const SW_RESTORE = 9
 489 Private Const SW_SHOWDEFAULT = 10
 490 Private Const SW_MAX = 10
 491 
 492 ' Window Message
 493 Private Const WM_MOUSEFIRST = &H200
 494 Private Const WM_MOUSEMOVE = &H200
 495 Private Const WM_LBUTTONDOWN = &H201
 496 Private Const WM_LBUTTONUP = &H202
 497 Private Const WM_LBUTTONDBLCLK = &H203
 498 Private Const WM_RBUTTONDOWN = &H204
 499 Private Const WM_RBUTTONUP = &H205
 500 Private Const WM_RBUTTONDBLCLK = &H206
 501 Private Const WM_MBUTTONDOWN = &H207
 502 Private Const WM_MBUTTONUP = &H208
 503 Private Const WM_MBUTTONDBLCLK = &H209
 504 Private Const WM_MOUSELAST = &H209
 505 Private Const WM_SETFOCUS = &H7
 506 Private Const WM_KILLFOCUS = &H8
 507 Private Const WM_MOVE = &H3
 508 Private Const WM_SIZE = &H5
 509 
 510 
 511 Private Const WM_ENABLE = &HA
 512 Private Const WM_SETREDRAW = &HB
 513 
 514 ' Virtual Keys, Standard Set
 515 Private Const VK_LBUTTON = &H1
 516 Private Const VK_RBUTTON = &H2
 517 Private Const VK_CANCEL = &H3
 518 Private Const VK_MBUTTON = &H4             '  NOT contiguous with L RBUTTON
 519 
 520 Private Const VK_BACK = &H8
 521 Private Const VK_TAB = &H9
 522 
 523 Private Const VK_CLEAR = &HC
 524 Private Const VK_RETURN = &HD
 525 
 526 Private Const VK_SHIFT = &H10
 527 Private Const VK_CONTROL = &H11
 528 Private Const VK_MENU = &H12
 529 Private Const VK_PAUSE = &H13
 530 Private Const VK_CAPITAL = &H14
 531 
 532 Private Const VK_ESCAPE = &H1B
 533 Private Const VK_SPACE = &H20
 534 Private Const VK_PRIOR = &H21
 535 Private Const VK_NEXT = &H22
 536 Private Const VK_END = &H23
 537 Private Const VK_HOME = &H24
 538 Private Const VK_LEFT = &H25
 539 Private Const VK_UP = &H26
 540 Private Const VK_RIGHT = &H27
 541 Private Const VK_DOWN = &H28
 542 
 543 Private Const MB_ICONHAND = &H10&
 544 Private Const MB_ICONQUESTION = &H20&
 545 Private Const MB_ICONEXCLAMATION = &H30&
 546 Private Const MB_ICONASTERISK = &H40&
 547 Private Const MB_ICONINFORMATION = MB_ICONASTERISK
 548 Private Const MB_ICONSTOP = MB_ICONHAND
 549 
 550 Private Const MF_UNCHECKED = &H0&
 551 Private Const MF_CHECKED = &H8&
 552 Private Const MF_USECHECKBITMAPS = &H200&
 553 Private Const MF_MENUBARBREAK = &H20&
 554 Private Const MF_MENUBREAK = &H40&
 555 Private Const MF_SEPARATOR = &H800&
 556 
 557 Private Const NM_FIRST = 0   '  // generic to all controls
 558 Private Const NM_LAST = -99
 559 Private Const NM_RELEASEDCAPTURE = (NM_FIRST - 16)
 560 
 561 Private Const MF_BYPOSITION = &H400&
 562 Private Const MF_POPUP = &H10&
 563 Private Const MF_STRING = &H0&
 564 Private Const GWL_WNDPROC = (-4)
 565 Private Const WM_COMMAND = &H111
 566 
 567 Private Const DTN_FIRST  As Long = -760
 568 Private Const DTN_LAST  As Long = -799
 569 
 570 Private Const MCN_FIRST  As Long = -750
 571 Private Const MCN_LAST As Long = -799
 572 Private Const MCN_GETDAYSTATE As Long = (MCN_FIRST + 3)
 573 
 574 Private Const MCN_SELECT As Long = (MCN_FIRST + 4)
 575 Private Const MCN_SELCHANGE As Long = (MCN_FIRST + 1)
 576 
 577 Private Const NM_KEYDOWN = (NM_FIRST - 15)
 578 Private Const NM_DBLCLK = (NM_FIRST - 3)
 579 
 580 
 581 'Color part's of the Calendar
 582 Private Const MCSC_BACKGROUND = 0    '// the background color (between months)
 583 Private Const MCSC_TEXT = 1          '// the dates
 584 Private Const MCSC_TITLEBK = 2       '// background of the title
 585 Private Const MCSC_TITLETEXT = 3
 586 Private Const MCSC_MONTHBK = 4       '// background within the month cal
 587 Private Const MCSC_TRAILINGTEXT = 5  '/
 588 
 589 Private Const MCM_FIRST = &H1000&
 590 Private Const MCM_HITTEST = MCM_FIRST + 14
 591 
 592 Private Const MCHT_TITLE = &H10000
 593 Private Const MCHT_CALENDAR = &H20000
 594 Private Const MCHT_TODAYLINK = &H30000
 595 
 596 Private Const MCHT_NEXT = &H1000000
 597 '// these indicate that hitting
 598 Private Const MCHT_PREV = &H2000000
 599 '// here will go to the next/prev month
 600 
 601 Private Const MCHT_NOWHERE = &H0
 602 
 603 Private Const MCHT_TITLEBK = (MCHT_TITLE)
 604 Private Const MCHT_TITLEMONTH = (MCHT_TITLE Or &H1)
 605 Private Const MCHT_TITLEYEAR = (MCHT_TITLE Or &H2)
 606 Private Const MCHT_TITLEBTNNEXT = (MCHT_TITLE Or MCHT_NEXT Or &H3)
 607 Private Const MCHT_TITLEBTNPREV = (MCHT_TITLE Or MCHT_PREV Or &H3)
 608 
 609 Private Const MCHT_CALENDARBK = (MCHT_CALENDAR)
 610 Private Const MCHT_CALENDARDATE = (MCHT_CALENDAR Or &H1)
 611 Private Const MCHT_CALENDARDATENEXT = (MCHT_CALENDARDATE Or MCHT_NEXT)
 612 Private Const MCHT_CALENDARDATEPREV = (MCHT_CALENDARDATE Or MCHT_PREV)
 613 Private Const MCHT_CALENDARDAY = (MCHT_CALENDAR Or &H2)
 614 Private Const MCHT_CALENDARWEEKNUM = (MCHT_CALENDAR Or &H3)
 615 
 616 
 617 ' We'll translate above color indexes into Menu ID's
 618 ' by adding 1000 to the values
 619 
 620 ' MISC Properties
 621 
 622 'Use Single Or Double Click to Select a Date
 623 Private Const SingleOrDouble = 720
 624 Private Const SingleClick = 721
 625 Private Const DoubleClick = 722
 626 
 627 
 628 'Show Week Numbers
 629 Private Const ShowWeekNum = 700
 630 Private Const ShowWeekNumYES = 701
 631 Private Const ShowWeekNumNO = 702
 632 
 633 'Show Today TodayNumbers
 634 Private Const ShowToday = 705
 635 Private Const ShowTodayYES = 706
 636 Private Const ShowTodayNO = 707
 637 
 638 'Show CircleToday Numbers
 639 Private Const ShowcircleToday = 708
 640 Private Const ShowCircleTodayYES = 709
 641 Private Const ShowCircleTodayNO = 710
 642 
 643 ' Font Dialog Menu
 644 Private Const FontDialog = 820
 645 
 646 ' Font Size Menu
 647 Private Const Fontx5 = 805
 648 
 649 ' Weeks Menu
 650 Private Const Monthx1 = 901
 651 Private Const Monthx2 = 902
 652 Private Const Monthx3 = 903
 653 Private Const Monthx4 = 904
 654 Private Const Monthx6 = 906
 655 Private Const Monthx8 = 908
 656 Private Const Monthx9 = 909
 657 Private Const Monthx12 = 912
 658 
 659 ' WindowPosition menu
 660 Private Const Positionx0 = 920
 661 Private Const Positionx1 = 921
 662 Private Const Positionx2 = 922
 663 Private Const Positionx3 = 923
 664 Private Const Positionx4 = 924
 665 Private Const Positionx5 = 925
 666 Private Const Positionx6 = 926
 667 Private Const Positionx7 = 927
 668 Private Const Positionx8 = 928
 669 
 670 ' Variables to store our dynamic menu's item IDs
 671 Private Menu1 As Long
 672 Private Menu2 As Long
 673 Private Menu3 As Long
 674 Private Menu4 As Long
 675 Private Menu5 As Long
 676 Private Menu6 As Long
 677 Private Menu7 As Long
 678 
 679 ' Junk Vars
 680 Private lngRet As Long
 681 Private lngTemp As Long
 682 
 683 ' Module level var to hold handle to our Calendars hWnd
 684 Private hWndCalendar As Long
 685 
 686 ' Module level var to hold reference to our Calendar object
 687 ' We need this to access the Class from the WindowProc function
 688 Private mc As cMonthCtrl
 689 
 690 ' Module level variable to hold the currently selected date
 691 Private SelectedDate As Date
 692 
 693 ' Module level variables to hold local copy of
 694 ' the currently selected Starting and Ending date Ranges
 695 Private localStartSelectedDate As Date
 696 Private localEndSelectedDate As Date
 697 
 698 ' Module Var to track whether a Font or Color
 699 ' Dialog window is currently Open.
 700 Private blDialogOpen As Boolean
 701 
 702 
 703 ' Required to be Module level in order for WindowProc to have access to Menu handles
 704 Dim hMenu As Long
 705 Dim hMenuPop As Long
 706 Dim hMenuPopMisc As Long
 707 Dim hMenuPopMiscShowWeekNumbers As Long
 708 Dim hMenuPopMiscFont  As Long
 709 Dim hMenuPopMiscColor As Long
 710 Dim hMenuPopMiscToday  As Long
 711 Dim hMenuPopMiscCircleToday  As Long
 712 Dim hMenuPopMiscWindowPosition  As Long
 713 Dim hMenuPopMiscOneClick  As Long
 714 
 715 ' To allow for Keyboard selection of Date(s)
 716 Dim SelChangeDateStart As Date
 717 Dim SelChangeDateEnd As Date
 718 
 719 ''' // Create unique naming of Class and unique labeling of Controls Title by using (one!) constant accross this module.
 720 ''' // The same constants are used within the class module.
 721 Const CLASSNAME As String = "MonthCalendar"
 722 Const TITLE As String = "Date Picker:"
 723 
 724 
 725 
 726 Public Function ShowMonthCalendar(ByRef clsMC As cMonthCtrl, _
 727                                                             ByRef StartSelectedDate As Date, _
 728                                                             Optional ByRef EndSelectedDate As Date = 0, _
 729                                                             Optional ByRef TimeArray As Variant) As Boolean
 730 
 731 
 732 ' ************************************************************
 733 ' March 22, 2004
 734 ' Major modification to the function logic including calling Parameter order.
 735 ' Changed function to return Boolean FALSE and "StartSelectedDate =0"
 736 ' if user did not select a date from the MonthCalendar.
 737 ' The hWndForm param is no longer optional.
 738 ' ************************************************************
 739 
 740 
 741 ' ********* WARNING *************
 742 ' In order for this function to return Focus to the calling Form properly
 743 ' you must set the MonthCalendar class's hWndForm property BEFORE
 744 ' Calling this function!!!!!!!!!!
 745 ' *******************************
 746 
 747 ' This function will always return the date selected by the
 748 ' user in the MonthCalendar as the return value for this function.
 749 ' If this function is called with the optional Date Range variables
 750 ' then it will also return the starting and ending dates of the
 751 ' range of dates selected by the user.
 752 ' Finally if StartSelectedDate and EndSelectedDate <> 0 Then their
 753 ' values will be used to initialize the Calendar.
 754 '
 755 
 756 'Const mcCLASSNAME As String = "MonthCalendar"
 757 'Const mcTITLE As String = "Date Picker:"
 758 
 759 Dim hwnd As Long, appHWnd As Long
 760 Dim wc As WNDCLASSEX
 761 ' Class Atom
 762 Dim lngClassAtom As Long
 763 Dim message As msg
 764 Dim hInstance As Long
 765 Dim lTemp As Long
 766 Dim ctr As Long
 767 Dim pt As POINTAPI
 768 Dim s As String
 769 Dim blFormIsPopup As Boolean
 770 Dim blFormIsModal As Boolean
 771 Dim blAppWindowIsModal As Boolean
 772 
 773     On Error Resume Next
 774 
 775     ' Make sure the instance of MonthCalendar class is valid!
 776     If clsMC Is Nothing Then
 777         s = " The MonthCalendar class instance you passed to this function is INVALID!" & vbCrLf
 778         s = s & " You must instantiate the MonthCalendar Class object before you call this function" & vbCrLf
 779         s = s & " The code behind the sample Form shows you how to do this in the Form's Load event" & vbCrLf & vbCrLf
 780         s = s & "' This must appear here!" & vbCrLf
 781         s = s & "' Create an instance of our Class" & vbCrLf
 782         s = s & "Private Sub Form_Load()" & vbCrLf
 783         s = s & "Set mc = New clsMonthCal" & vbCrLf
 784         s = s & "' You must set the class hWndForm prop!!!" & vbCrLf
 785         s = s & "mc.hWndForm = Me.hWnd"
 786         MsgBox s, vbOKOnly, "Invalid MonthCalendar object!"
 787         ' Return nothing!
 788         ShowMonthCalendar = 0
 789         Exit Function
 790     End If
 791 
 792 
 793     ' If this window already exists then exit!
 794     'lngRet = FindWindow("MonthCalendar", "Month Calendar")
 795     lngRet = FindWindow(CLASSNAME, TITLE)
 796     If lngRet <> 0 Then
 797         's = "The Calendar Window Already Exists!" & vbCrLf
 798         's = s & "Please Close and then Restart Access!"
 799         'MsgBox s, vbCritical, "Critical Error. The MonthCalendar Window already exists"
 800         ' Return nothing!
 801         'ShowMonthCalendar = 0
 802         ' We can just Return. The user has tried to open another instance of the Calendar.
 803         ' Up to this point, Version 98b, we only support one open instance at a time
 804         ShowMonthCalendar = 0
 805         Exit Function
 806     End If
 807 
 808     ' Create a local copy of the MonthCalendar class
 809     Set mc = clsMC
 810 
 811     ' Update our init cursor props.
 812     lngRet = GetCursorPos(pt)
 813     mc.CursorXinit = pt.X
 814     mc.CursorYinit = pt.y
 815 
 816     ' Ensure our SelChange vars are reset
 817     SelChangeDateStart = 0
 818     SelChangeDateEnd = 0
 819 
 820 
 821     ' MENU creation time!
 822     hMenu = CreateMenu
 823     hMenuPop = CreatePopupMenu
 824     hMenuPopMisc = CreatePopupMenu
 825     hMenuPopMiscShowWeekNumbers = CreatePopupMenu
 826     hMenuPopMiscFont = CreatePopupMenu
 827     hMenuPopMiscColor = CreatePopupMenu
 828     hMenuPopMiscToday = CreatePopupMenu
 829     hMenuPopMiscCircleToday = CreatePopupMenu
 830     hMenuPopMiscWindowPosition = CreatePopupMenu
 831     hMenuPopMiscOneClick = CreatePopupMenu
 832 
 833     ' Viewable Months Menu
 834     lngRet = InsertMenu(hMenuPopMisc, 1&, MF_POPUP Or MF_BYPOSITION Or MF_ENABLED, hMenuPop, "Viewable Months")
 835     ' Viewable Months SubMenus
 836     lngRet = InsertMenu(hMenuPop, 0&, MF_STRING Or MF_BYPOSITION, Monthx1, "1 Month")
 837     lngRet = InsertMenu(hMenuPop, 0&, MF_STRING Or MF_BYPOSITION, Monthx2, "2 Months")
 838     lngRet = InsertMenu(hMenuPop, 0&, MF_STRING Or MF_BYPOSITION, Monthx3, "3 Months")
 839     lngRet = InsertMenu(hMenuPop, 0&, MF_STRING Or MF_BYPOSITION, Monthx4, "4 Months")
 840     lngRet = InsertMenu(hMenuPop, 0&, MF_STRING Or MF_BYPOSITION, Monthx6, "6 Months")
 841     lngRet = InsertMenu(hMenuPop, 0&, MF_STRING Or MF_BYPOSITION, Monthx8, "8 Months")
 842     lngRet = InsertMenu(hMenuPop, 0&, MF_STRING Or MF_BYPOSITION, Monthx9, "9 Months")
 843     lngRet = InsertMenu(hMenuPop, 0&, MF_STRING Or MF_BYPOSITION, Monthx12, "12 Months")
 844     ' Erase all check marks
 845 
 846     For ctr = 0 To 7
 847         lngRet = CheckMenuItem(hMenuPop, 0, MF_UNCHECKED Or MF_BYPOSITION)
 848     Next ctr
 849 
 850     ' Now set the Menu Check the current number of months displayed
 851     lTemp = (mc.MonthColumns * mc.MonthRows)
 852     Select Case lTemp
 853         Case 1
 854         ctr = 7
 855 
 856         Case 2
 857         ctr = 6
 858 
 859         Case 3
 860         ctr = 5
 861 
 862         Case 4
 863         ctr = 4
 864 
 865         Case 6
 866         ctr = 3
 867 
 868         Case 8
 869         ctr = 2
 870 
 871         Case 9
 872         ctr = 1
 873 
 874         Case 12
 875         ctr = 0
 876 
 877     End Select
 878 
 879     ' Now set the Menu Check
 880     lngRet = CheckMenuItem(hMenuPop, ctr, MF_CHECKED Or MF_BYPOSITION)
 881 
 882     ' Misc Properties Menu
 883     lngRet = InsertMenu(hMenu, 2&, MF_POPUP Or MF_BYPOSITION Or MF_ENABLED, hMenuPopMisc, "Properties")
 884 
 885     ' Let's add Top level Menu Item that does not contain any submen items.
 886     ' We will use it like a CommandButton to allow the users to Close the Calendar Window.
 887     lngRet = InsertMenu(hMenu, 1&, MF_BYPOSITION Or MF_ENABLED, 998, "Close Window")
 888 
 889     ' Show WeekNumbers SubMenu
 890     lngRet = InsertMenu(hMenuPopMisc, 1&, MF_POPUP Or MF_BYPOSITION Or MF_ENABLED, hMenuPopMiscShowWeekNumbers, "ShowWeek#'s")
 891     lngRet = InsertMenu(hMenuPopMiscShowWeekNumbers, 0&, MF_STRING Or MF_BYPOSITION, ShowWeekNumYES, "YES")
 892     lngRet = InsertMenu(hMenuPopMiscShowWeekNumbers, 0&, MF_STRING Or MF_BYPOSITION, ShowWeekNumNO, "NO")
 893     If mc.ShowWeekNumbers = False Then
 894         lngRet = CheckMenuItem(hMenuPopMiscShowWeekNumbers, 0, MF_CHECKED Or MF_BYPOSITION)
 895         lngRet = CheckMenuItem(hMenuPopMiscShowWeekNumbers, 1, MF_UNCHECKED Or MF_BYPOSITION)
 896     Else
 897         lngRet = CheckMenuItem(hMenuPopMiscShowWeekNumbers, 1, MF_CHECKED Or MF_BYPOSITION)
 898         lngRet = CheckMenuItem(hMenuPopMiscShowWeekNumbers, 0, MF_UNCHECKED Or MF_BYPOSITION)
 899     End If
 900 
 901     ' Font stuff SubMenu
 902     lngRet = InsertMenu(hMenuPopMisc, 2&, MF_POPUP Or MF_BYPOSITION Or MF_ENABLED, hMenuPopMiscFont, "Font")
 903     lngRet = InsertMenu(hMenuPopMiscFont, 0&, MF_STRING Or MF_BYPOSITION, FontDialog, "Select Font")
 904 
 905     ' Color Props SubMenu
 906     lngRet = InsertMenu(hMenuPopMisc, 3&, MF_POPUP Or MF_BYPOSITION Or MF_ENABLED, hMenuPopMiscColor, "Colors")
 907     lngRet = InsertMenu(hMenuPopMiscColor, 0&, MF_STRING Or MF_BYPOSITION, MCSC_MONTHBK + 1000, "BackGround Color")
 908     lngRet = InsertMenu(hMenuPopMiscColor, 0&, MF_STRING Or MF_BYPOSITION, MCSC_BACKGROUND + 1000, "Frame Color")
 909     lngRet = InsertMenu(hMenuPopMiscColor, 0&, MF_STRING Or MF_BYPOSITION, MCSC_TEXT + 1000, "Dates Color")
 910     lngRet = InsertMenu(hMenuPopMiscColor, 0&, MF_STRING Or MF_BYPOSITION, MCSC_TITLEBK + 1000, "Title BG Color")
 911     lngRet = InsertMenu(hMenuPopMiscColor, 0&, MF_STRING Or MF_BYPOSITION, MCSC_TITLETEXT + 1000, "Title Text Color")
 912     lngRet = InsertMenu(hMenuPopMiscColor, 0&, MF_STRING Or MF_BYPOSITION, MCSC_TRAILINGTEXT + 1000, "Trailing Text Color")
 913     lngRet = InsertMenu(hMenuPopMiscColor, 0&, MF_STRING Or MF_BYPOSITION, MCSC_TRAILINGTEXT + 2000, "Reset All Colors")
 914 
 915     ' Show Today's Date
 916     lngRet = InsertMenu(hMenuPopMisc, 4&, MF_POPUP Or MF_BYPOSITION Or MF_ENABLED, hMenuPopMiscToday, "Show Today")
 917     lngRet = InsertMenu(hMenuPopMiscToday, 0&, MF_STRING Or MF_BYPOSITION, ShowTodayYES, "YES")
 918     lngRet = InsertMenu(hMenuPopMiscToday, 0&, MF_STRING Or MF_BYPOSITION, ShowTodayNO, "NO")
 919 
 920     If mc.NoToday = True Then
 921         lngRet = CheckMenuItem(hMenuPopMiscToday, 0, MF_CHECKED Or MF_BYPOSITION)
 922         lngRet = CheckMenuItem(hMenuPopMiscToday, 1, MF_UNCHECKED Or MF_BYPOSITION)
 923     Else
 924         lngRet = CheckMenuItem(hMenuPopMiscToday, 1, MF_CHECKED Or MF_BYPOSITION)
 925         lngRet = CheckMenuItem(hMenuPopMiscToday, 0, MF_UNCHECKED Or MF_BYPOSITION)
 926     End If
 927 
 928     ' Circle Today's Date
 929     lngRet = InsertMenu(hMenuPopMisc, 5&, MF_POPUP Or MF_BYPOSITION Or MF_ENABLED, hMenuPopMiscCircleToday, "Circle Today")
 930     lngRet = InsertMenu(hMenuPopMiscCircleToday, 0&, MF_STRING Or MF_BYPOSITION, ShowCircleTodayYES, "YES")
 931     lngRet = InsertMenu(hMenuPopMiscCircleToday, 0&, MF_STRING Or MF_BYPOSITION, ShowCircleTodayNO, "NO")
 932     If mc.NoTodayCircle = True Then
 933         lngRet = CheckMenuItem(hMenuPopMiscCircleToday, 0, MF_CHECKED Or MF_BYPOSITION)
 934         lngRet = CheckMenuItem(hMenuPopMiscCircleToday, 1, MF_UNCHECKED Or MF_BYPOSITION)
 935     Else
 936         lngRet = CheckMenuItem(hMenuPopMiscCircleToday, 1, MF_CHECKED Or MF_BYPOSITION)
 937         lngRet = CheckMenuItem(hMenuPopMiscCircleToday, 0, MF_UNCHECKED Or MF_BYPOSITION)
 938     End If
 939 
 940     ' Window Position
 941     lngRet = InsertMenu(hMenuPopMisc, 6&, MF_POPUP Or MF_BYPOSITION Or MF_ENABLED, hMenuPopMiscWindowPosition, "Calendar Location")
 942     lngRet = InsertMenu(hMenuPopMiscWindowPosition, 0&, MF_STRING Or MF_BYPOSITION, Positionx0, "Cursor Location when Calendar Opened")
 943     lngRet = InsertMenu(hMenuPopMiscWindowPosition, 0&, MF_STRING Or MF_BYPOSITION, Positionx1, "Where User Last Dragged")
 944     lngRet = InsertMenu(hMenuPopMiscWindowPosition, 0&, MF_STRING Or MF_BYPOSITION, Positionx2, "Center of Access App Window")
 945     lngRet = InsertMenu(hMenuPopMiscWindowPosition, 0&, MF_STRING Or MF_BYPOSITION, Positionx3, "Center of Screen")
 946     lngRet = InsertMenu(hMenuPopMiscWindowPosition, 0&, MF_STRING Or MF_BYPOSITION, Positionx4, "Top Left Corner")
 947 
 948     For ctr = 0 To 4
 949         lngRet = CheckMenuItem(hMenuPopMiscWindowPosition, ctr, MF_UNCHECKED Or MF_BYPOSITION)
 950     Next ctr
 951 
 952     ' Now set the Menu Check the current number of months displayed
 953     lTemp = (mc.WindowLocation)
 954     ' Now set the Menu Check
 955     lngRet = CheckMenuItem(hMenuPopMiscWindowPosition, 4 - lTemp, MF_CHECKED Or MF_BYPOSITION)
 956 
 957     ' Single or Double Click to select Date
 958     lngRet = InsertMenu(hMenuPopMisc, 7&, MF_POPUP Or MF_BYPOSITION Or MF_ENABLED, hMenuPopMiscOneClick, "Single Or Double Click")
 959     lngRet = InsertMenu(hMenuPopMiscOneClick, 0&, MF_STRING Or MF_BYPOSITION, DoubleClick, "Double Click to Select Date")
 960     lngRet = InsertMenu(hMenuPopMiscOneClick, 0&, MF_STRING Or MF_BYPOSITION, SingleClick, "Single Click to Select Date")
 961 
 962     If mc.OneClick = True Then
 963         lngRet = CheckMenuItem(hMenuPopMiscOneClick, 0, MF_CHECKED Or MF_BYPOSITION)
 964         lngRet = CheckMenuItem(hMenuPopMiscOneClick, 1, MF_UNCHECKED Or MF_BYPOSITION)
 965     Else
 966         lngRet = CheckMenuItem(hMenuPopMiscOneClick, 1, MF_CHECKED Or MF_BYPOSITION)
 967         lngRet = CheckMenuItem(hMenuPopMiscOneClick, 0, MF_UNCHECKED Or MF_BYPOSITION)
 968     End If
 969 
 970     ' Get instance of this App
 971     ''' // For Excel 2K we require getting handle to Window differently
 972     If Val(Application.Version) < 10 Then
 973         appHWnd = FindWindow("XLMAIN", vbNullString)
 974     Else
 975         appHWnd = Application.hwnd
 976     End If
 977 
 978     hInstance = apiGetWindowLong(appHWnd, GWL_HINSTANCE)
 979 
 980     ' From code by Ray Mercer
 981     ' Set up and register window class
 982     wc.cbSize = Len(wc)
 983     wc.Style = CS_HREDRAW Or CS_VREDRAW
 984 
 985     ' Determine Access Version
 986     ' **************************
 987     ' For A97 MUST USE AddrOf
 988     ' **************************
 989     'If Val(SysCmd(acSysCmdAccessVer)) < 8 Then
 990     'wc.lpfnWndProc = AddrOf("WindowProc")
 991     'Else
 992 
 993     ''' // Using Excel 97 or smaller this will crash as this did not support AddressOf
 994     wc.lpfnWndProc = GetFuncPtr(AddressOf WindowProc)
 995     'End If
 996 
 997     wc.cbClsExtra = 0&
 998     wc.cbWndExtra = 0&
 999     wc.hInstance = hInstance
1000     wc.hIcon = LoadIcon(hInstance, IDI_APPLICATION)
1001     wc.hCursor = LoadCursor(hInstance, IDC_ARROW)
1002     wc.hbrBackground = GetStockObject(WHITE_BRUSH)
1003     wc.lpszMenuName = 0&
1004     wc.lpszClassName = CLASSNAME
1005     wc.hIconSm = LoadIcon(hInstance, IDI_APPLICATION)
1006 
1007     ' Register this Class
1008     lngClassAtom = RegisterClassEx(wc)
1009 
1010     ' We have to allow for the following:
1011     ' 1) The calling Form's Modal prop is turned on
1012     ''' // **************
1013     ''' // But this gets the application windows properties ... anyhow, disabling this prevents from closing the application and have it crash because
1014     ''' // the MonthControl was still active.
1015     lngRet = GetWindowLong(appHWnd, GWL_STYLE)
1016     blAppWindowIsModal = lngRet And WS_DISABLED
1017 
1018     ''' // This gets the parents UserForm properties
1019     lngRet = GetWindowLong(mc.hWndForm, GWL_STYLE)
1020     blFormIsModal = lngRet And WS_DISABLED
1021     ''' // **************
1022 
1023     ' 2) The calling Form's Popup prop is turned on
1024     lngRet = GetWindowLong(mc.hWndForm, GWL_STYLE)
1025     blFormIsPopup = lngRet And WS_POPUP
1026 
1027     ' The following logic is required to ensure our MonthCalendar window
1028     ' is MODAL (the user can only click in this window)
1029     ' If parent form's Popup prop is turned on then
1030     ' we have to Disable this Form ourselves
1031     If blFormIsPopup Then lngRet = EnableWindow(mc.hWndForm, 0)
1032 
1033     ' We only want to Disable the main app window if
1034     ' the Form's Modal prop is not true.
1035     ' Check and see if the main Access app window
1036     ' is disabled already - if not then disable it
1037 
1038     ''' // ****
1039     ''' // Note: This seems to be a wrong approach - it is not just the application window which has to be disabled it is the the user form calling the DatePicker, too.
1040     ''' //          A better approach should test the UserForm Window for being modal.
1041     If Not blAppWindowIsModal Then
1042         lngRet = EnableWindow(appHWnd, 0)
1043     End If
1044 
1045     ''' // Force calling UserForm to be modal
1046     If Not blFormIsModal Then
1047         lngRet = EnableWindow(mc.hWndForm, 0)
1048     End If
1049     ''' // ****
1050 
1051     Dim lngEXStyle As Long
1052     ' Force window to always stay on top
1053     lngEXStyle = WS_EX_DLGMODALFRAME ' April 6 trying to fix WIn98 Form in Popup view Or WS_EX_TOPMOST
1054 
1055     ' Create a window Set to be NOT VISIBLE TO START Or WS_VISIBLE
1056     hwnd = CreateWindowEx(lngEXStyle, _
1057                                                 CLASSNAME, _
1058                                                 TITLE, _
1059                                                 WS_POPUPWINDOW Or WS_CAPTION, _
1060                                                 CW_USEDEFAULT, _
1061                                                 CW_USEDEFAULT, _
1062                                                 CW_USEDEFAULT, _
1063                                                 CW_USEDEFAULT, _
1064                                                 mc.hWndForm, _
1065                                                 hMenu, _
1066                                                 hInstance, _
1067                                                  0&)
1068 
1069     ' We will actually create our MonthCal window by setting the
1070     ' Class hWnd property.
1071     ' Set the Control's Parent Window property
1072     mc.hwnd = hwnd
1073 
1074     ' Init the Calendar to the date(s) supplied by the
1075     ' user in the calling function
1076     If StartSelectedDate <> 0 And EndSelectedDate <> 0 Then
1077         mc.SetSelectedDateRange StartSelectedDate, EndSelectedDate
1078         ' Update our local copies of these vars
1079         ' Need to redo the logic to get rid of these local vars
1080         ' See the date select code in the WindProc
1081         localStartSelectedDate = StartSelectedDate
1082         localEndSelectedDate = EndSelectedDate
1083         ' Clear our Return Date local Var.
1084         SelectedDate = 0
1085     Else
1086         If StartSelectedDate <> 0 Then
1087             mc.SelectedDate = StartSelectedDate
1088             ' Clear our Return Date local Var.
1089             SelectedDate = 0
1090         Else
1091             SelectedDate = 0
1092             localStartSelectedDate = 0
1093             localEndSelectedDate = 0
1094         End If
1095     End If
1096 
1097     ''' // Ver.: 3.0.0; 22.05.2009; (c) digital-ecom GmbH
1098     ''' // Allow specifying a restriced date range
1099     ''' // If Calendar Ctrl uses a restricted date range (TMPArray is set), apply restriction
1100     If IsEmpty(TimeArray) Then
1101     Else
1102         If IsArray(TimeArray) Then
1103             Call mc.SetDateRange(TimeArray)
1104         End If
1105     End If
1106 
1107     ' Show the Calendar's Parent window first then the MonthCal window
1108     ShowWindow hwnd, SW_SHOWNORMAL
1109     ShowWindow mc.hWndCal, SW_SHOWNORMAL
1110 
1111     ' Enter message loop
1112     ' (all window messages are handled in WindowProc())
1113     Do While 0 <> GetMessage(message, 0&, 0&, 0&)
1114         TranslateMessage message
1115         DispatchMessage message
1116     Loop
1117 
1118     ' User has closed the MonthCalendar window
1119     ' Return the Selected Date
1120     ' If the user has called this function with the optional
1121     ' date range vars then fill them in.
1122     If SelectedDate <> 0 Then
1123         ' The Calendar Window is closed so we cannot
1124         ' use our Class methods that use SendMessage
1125         ' to get their current values.
1126         StartSelectedDate = SelectedDate
1127         EndSelectedDate = localEndSelectedDate
1128         ShowMonthCalendar = True
1129     Else
1130         ' User did not SELECT a Date
1131         StartSelectedDate = 0
1132         EndSelectedDate = 0
1133         ShowMonthCalendar = False
1134     End If
1135 
1136     ' Unregister our Custom Window Class
1137     ' If you don't then you will GPF on the next init of the class
1138     lngRet = UnregisterClass(CLASSNAME, hInstance)
1139 
1140     ' If Form was Popup then Enable this window first
1141     If blFormIsPopup Then
1142         lngRet = EnableWindow(mc.hWndForm, 1)
1143     End If
1144 
1145     ' In order to prevent screen flashing upon closing
1146     ' our MonthCalendar window we have to enable the
1147     ' main Access application window in the MonthCalendar's
1148     ' WinProc's WM_CLOSE message handler. From here now though,
1149     ' we  have to Disable the main Access application window
1150     ' if the calling form's Modal prop was turned on.
1151     'If blAppWindowIsModal Then
1152         'Disable Access App window
1153     '    lngRet = EnableWindow(appHWnd, 0)
1154     'End If
1155 
1156     ''' // Ver.: 3.0.0; May 2009; (c) digital-ecom GmbH
1157     ''' // Force the application window to be enabled again - this will allow using
1158     ''' // the DatePicker Control with modeless user forms, too.
1159     ''' // The above coding is no longer required since we handled screen flickering
1160     ''' // and other issues in WinProc's WM_CLOSE message handler differently.
1161     lngRet = EnableWindow(appHWnd, 1)
1162 
1163     If blFormIsModal Then
1164         lngRet = EnableWindow(mc.hWndForm, 1)
1165     End If
1166 
1167      ' Release Class reference required to be visible to our WindProc
1168     Set mc = Nothing
1169 
1170     ' Ensure focus returns to calling form.
1171     SetFocus clsMC.hWndForm
1172 End Function
1173 
1174 
1175 'Main message handler for the MonthCalendar window
1176 ' *** WARNING ***
1177 ' DO NOT PLACE DEBUG BREAKPOINTS IN THIS FUNCTION
1178 ' *** WARNING ***
1179 Public Function WindowProc(ByVal hwnd As Long, ByVal message As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
1180 Dim ps As PAINTSTRUCT
1181 Dim rc As RECT
1182 Dim hdc As Long
1183 Dim strTemp As String, strTemp1  As String
1184 Dim lngRet As Long
1185 Dim blRet As Boolean
1186 
1187 Dim intTemp As Integer
1188 Dim arrayTime(0 To 1) As SYSTEMTIME
1189 ' Mouse selection of Date(s)
1190 Dim DateStart As Date
1191 Dim DateEnd As Date
1192 
1193 Dim nmsc As NMSELCHANGE
1194 Dim hdr As NMHDR
1195 Dim nmds As NMDAYSTATE
1196 ' There is a bug or I am having alignment problems
1197 ' so we pass the second element of this array
1198 ' and leave the first zero'd out.
1199 Dim aMDS(-1 To 13) As MONTHDAYSTATE
1200 
1201 ' To hold local copy of the current Message
1202 Dim CurMessage As msg
1203 Dim lngCurMessagetime  As Long
1204 Dim lngWMmessage As Long
1205 Dim lngDoubleClickTime As Long
1206 
1207 Static lngLastMouseDown As Long
1208 ' Flag to make sure we have a MouseUp bewtween our
1209 ' MouseDown messages to signify a Double Click
1210 ' not just the Mouse Button held down
1211 Static blMouseUp As Boolean
1212 
1213 ' Temp Window Handle for Dialogs
1214 Dim hWndTemp As Long
1215 
1216     ' You cannot have unhandled errors in a WinProc so
1217     ' we will just ingnore them all!!<grin>
1218     ' Really though, this is very heavily debugged code!
1219     On Error Resume Next
1220 
1221 
1222     Select Case message
1223 
1224         Case WM_MOVE
1225             ' Update the MonthCalendar's current
1226             Call UpdateCursor(lParam, hwnd)
1227 
1228         Case WM_PAINT
1229             ' Must leave this in to ensure Window is Redrawn!!!
1230             hdc = BeginPaint(hwnd, ps)
1231             Call EndPaint(hwnd, ps)
1232             Exit Function
1233 
1234         Case WM_KEYDOWN, WM_KEYUP
1235             ' Select case on the Virtual Key Code
1236             Select Case wParam
1237                 Case VK_ESCAPE
1238                     Call PostMessage(hwnd, WM_CLOSE, 0, 0)
1239                     Exit Function
1240 
1241                 Case VK_SHIFT, VK_LEFT, VK_RIGHT, VK_DOWN, VK_UP, VK_HOME, VK_END, vbKeyPageDown, vbKeyPageUp
1242                     KeysToMonthCal hwnd, message, wParam, lParam
1243                     Exit Function
1244 
1245                 Case VK_RETURN
1246                     ' If the SelChangeDateStart var != 0 then send our MCN_SELECT Message
1247                     If SelChangeDateStart = 0 Then Exit Function
1248 
1249                     If SelChangeDateEnd = SelChangeDateStart Then
1250                         mc.SelectedDate = SelChangeDateStart
1251                     Else
1252                         mc.SetSelectedDateRange SelChangeDateStart, SelChangeDateEnd
1253                     End If
1254 
1255                     ' Update our local var
1256                     SetSelectedDate SelChangeDateStart
1257                     ' Update our Class starting and ending date range vars
1258                     UpdateRangeVars SelChangeDateStart, SelChangeDateEnd
1259 
1260                    ' Let's CLose the Calendar
1261                      Call PostMessage(hwnd, WM_CLOSE, 0, 0)
1262                     'Debug
1263                     'Debug.Print "Used Enter key to select date!"
1264                     Exit Function
1265 
1266                 Case Else
1267                     WindowProc = DefWindowProc(hwnd, message, wParam, lParam)
1268                     Exit Function
1269 
1270                 End Select
1271 
1272         Case WM_CLOSE
1273             ' April 12, 2004
1274             ' FINALLY resolved issue of screen flickering with Win2K or higher!!
1275             ' We have to temporarily Enable the main Access application window
1276             'lngRet = EnableWindow(Application.hWndAccessApp, 1)
1277             ' lngRet = ShowWindow(Application.hWndAccessApp, SW_SHOW)
1278 
1279             ''' // BugFixed:
1280             ''' // First activate Excel Window, then close Calendar Ctrl - this assures we do not jump to other applications when simply closing
1281             ''' // the calendar Ctrl and it does prevent screen flickering.
1282             ''' // digital-ecom GmbH, 08.05.2009
1283             Dim appHWnd As Long
1284             If Val(Application.Version) < 10 Then
1285                 appHWnd = FindWindow("XLMAIN", vbNullString)
1286             Else
1287                 appHWnd = Application.hwnd
1288             End If
1289 
1290             Call SetForegroundWindow(appHWnd)
1291             WindowProc = DefWindowProc(hwnd, message, wParam, lParam)
1292             Exit Function
1293 
1294         Case WM_DESTROY
1295             'Exit Function
1296             ' Enable Main Access Window now
1297             ' that the MonthCalendar is closed!
1298             'lngRet = ShowWindow(Application.hWndAccessApp, SW_SHOW)
1299             PostQuitMessage 0&
1300             Exit Function
1301 
1302         Case WM_PARENTNOTIFY
1303             ' Grab the lower WORD
1304             lngWMmessage = (wParam And &HFFFF)
1305             ' Switch on Window Message
1306             Select Case lngWMmessage
1307                 Case WM_LBUTTONDOWN
1308 
1309                    ' Mod Nov 24 -2002
1310                    ' Removed MouseButton logic to determine when to close
1311                    ' calendar. Now we simply check it from the SELECT notification
1312                    ' and close the window if CHeckOneClick property is TRUE.
1313                    ' We do not use the DoubleCLick logic either.
1314                    ' Get the current Double Click interval
1315                     lngCurMessagetime = GetMessageTime
1316                     lngDoubleClickTime = GetDoubleClickTime
1317 
1318                     ' Make sure the Cursor is double clicking
1319                     ' on an actual Date not on a Calendar control
1320                     blRet = LocationCursorOnCalendar(lParam)
1321                     If Not blRet Then
1322                         ' Call the default WIndow proc
1323                         WindowProc = DefWindowProc(hwnd, message, wParam, lParam)
1324                         Exit Function
1325                     End If
1326 
1327                     ' Debug. A2K closing date range on one click!
1328                     If Abs((lngCurMessagetime - lngLastMouseDown)) < lngDoubleClickTime Then ' Or CheckOneClick = True Then
1329                         ' Double CLicked-or CheckOneClick-Let's CLose the Calendar
1330                         Call PostMessage(hwnd, WM_CLOSE, 0, 0)
1331                         lngLastMouseDown = 0
1332                         blMouseUp = False
1333                         Exit Function
1334                     End If
1335 
1336                     ' Always update our last left mouse button pressed var
1337                     lngLastMouseDown = lngCurMessagetime
1338 
1339 
1340                 Case Else
1341                     ' Call the default Window proc
1342                     WindowProc = DefWindowProc(hwnd, message, wParam, lParam)
1343                     Exit Function
1344 
1345                     ' All Done!
1346             End Select
1347 
1348         Case WM_NOTIFY
1349             ' Update our class startdate, and range date props.
1350             ' Copy the NMRH structure to our local copy
1351             CopyMem hdr, ByVal lParam, Len(hdr)
1352 
1353             Select Case hdr.code
1354                 ' Modified Nov 24 -2002
1355                 ' SELECT is when the user explicitly clicks to select a date.
1356                 ' SELCHANGE is when the user scrolls through the calendar automatically
1357                 ' updating the selected date.
1358                 ' Thanks to Blake Sell for catching this!
1359                 Case MCN_SELECT
1360                     ' *** this needs to be fixed up to have seperate routines
1361                     ' for single vs range date selections.
1362                     ' Drop local vars and use the MonthCalendar Class only
1363                     ' Grab the struct info
1364                     CopyMem nmsc, ByVal lParam, Len(nmsc)
1365 
1366                     ' Convert to our Date format
1367                     With nmsc.stSelStart '(0)
1368                         DateStart = DateSerial(.wYear, .wMonth, .wDay)
1369                     End With
1370                     With nmsc.stSelEnd '(1)
1371                         DateEnd = DateSerial(.wYear, .wMonth, .wDay)
1372                     End With
1373 
1374                     ' Update our local var
1375                     SetSelectedDate DateStart
1376                     ' Update our Class starting and ending date range vars
1377                     UpdateRangeVars DateStart, DateEnd
1378 
1379                    ' Mod Nov 24 -2002
1380                    ' Removed MouseButton logic to determine when to close
1381                    ' calendar. Now we simply check it from the SELECT notification
1382                    ' and close the window if CHeckOneClick property is TRUE.
1383                     If mc.OneClick = True Then
1384                         ' Double CLicked-or CheckOneClick-Let's CLose the Calendar
1385                         Call PostMessage(hwnd, WM_CLOSE, 0, 0)
1386                         lngLastMouseDown = 0
1387                         blMouseUp = False
1388                         'Exit Function
1389                     End If
1390 
1391                     Exit Function
1392 
1393                 ' June 2 - 2004 - adding support for ENTER key to select currently highlighted date.
1394                 Case MCN_SELCHANGE
1395 
1396                     ' Grab the struct info
1397                     CopyMem nmsc, ByVal lParam, Len(nmsc)
1398 
1399                     ' Convert to our Date format
1400                     With nmsc.stSelStart '(0)
1401                         SelChangeDateStart = DateSerial(.wYear, .wMonth, .wDay)
1402                     End With
1403                     With nmsc.stSelEnd '(1)
1404                         SelChangeDateEnd = DateSerial(.wYear, .wMonth, .wDay)
1405                     End With
1406                    ' Debug.Print "DateStart:" & DateStart
1407 
1408 
1409                 Case MCN_GETDAYSTATE
1410                     Dim s As SYSTEMTIME
1411                     Dim lngTemp As Long
1412                     Dim ptrArray As Long
1413 
1414                     Dim X As Integer
1415                     Dim intStartMonth As Integer
1416                     Dim intCurrentMonth As Integer
1417                     Dim intCurrentYear As Integer
1418 
1419                     For X = -1 To UBound(aMDS)
1420                         aMDS(X).lpMONTHDAYSTATE = 0
1421                     Next
1422 
1423                     CopyMem nmds, ByVal lParam, Len(nmds)
1424                     intTemp = nmds.cDayState
1425                     'Debug.Print "Months requested:" & intTemp
1426                     'Debug.Print time
1427                     ' Have to allow for the fact that the month before and
1428                     ' the month after are always requested. THis means the starting year
1429                     ' can be one year before the year of the first fully displayed month.
1430                     intStartMonth = nmds.stStart.wMonth
1431                     intCurrentYear = nmds.stStart.wYear
1432 
1433                     intCurrentMonth = intStartMonth '+ x
1434                     For X = 0 To intTemp - 1
1435                         If intCurrentMonth > 12 Then
1436                             intCurrentMonth = intCurrentMonth - 12 '1
1437                             intCurrentYear = intCurrentYear + 1
1438                         End If
1439                         aMDS(X).lpMONTHDAYSTATE = mc.GetDAYSTATE(intCurrentYear, intCurrentMonth)
1440                         intCurrentMonth = intCurrentMonth + 1
1441                     Next X
1442                     ' set the address of our array
1443                     lngTemp = VarPtr(aMDS(0))
1444                     CopyMem ByVal lParam + (Len(nmds) - 4), lngTemp, 4
1445 
1446                     ' Signal we want this message to be processed
1447                     WindowProc = 0
1448                     Exit Function
1449 
1450                 Case Else
1451                     WindowProc = DefWindowProc(hwnd, message, wParam, lParam)
1452 
1453             End Select
1454 
1455         Case WM_COMMAND:
1456         ' WM_COMMAND is sent to the window
1457         ' whenever someone clicks a PLA_Menu.
1458         ' The menu's item ID is stored in wParam.
1459 
1460                 Select Case wParam
1461                     Case Monthx1 To Monthx12
1462                         'Call MsgBox("You clicked Dynamic Sub Menu 1!", vbExclamation)
1463                         SetMonths (CInt(wParam) - 900)
1464                         Exit Function
1465 
1466                     Case ShowWeekNumYES
1467                         ShowWeekNums True
1468                         Exit Function
1469 
1470                     Case ShowWeekNumNO
1471                         ShowWeekNums False
1472                         Exit Function
1473 
1474                     Case FontDialog
1475                        ShowFontDialog
1476                        Exit Function
1477 
1478                     Case MCSC_BACKGROUND + 1000
1479                         SelectColor MCSC_BACKGROUND
1480                         Exit Function
1481 
1482                     Case MCSC_MONTHBK + 1000
1483                         SelectColor MCSC_MONTHBK
1484                         Exit Function
1485 
1486                     Case MCSC_TEXT + 1000
1487                         SelectColor MCSC_TEXT
1488                         Exit Function
1489 
1490                     Case MCSC_TITLEBK + 1000
1491                         SelectColor MCSC_TITLEBK
1492                         Exit Function
1493 
1494                     Case MCSC_TITLETEXT + 1000
1495                         SelectColor MCSC_TITLETEXT
1496                         Exit Function
1497 
1498                     Case MCSC_TRAILINGTEXT + 1000
1499                         SelectColor MCSC_TRAILINGTEXT
1500                         Exit Function
1501 
1502                     Case MCSC_TRAILINGTEXT + 2000
1503                         ResetColors
1504                         Exit Function
1505 
1506                     ' Show Todays Date at bottom of Calendar
1507                     Case ShowTodayYES
1508                         sShowToday False
1509                         Exit Function
1510 
1511                     Case ShowTodayNO
1512                         sShowToday True
1513                         Exit Function
1514 
1515                     ' Circle Today's Date
1516                     Case ShowCircleTodayYES
1517                         sShowcircleToday False
1518                         Exit Function
1519 
1520                     Case ShowCircleTodayNO
1521                         sShowcircleToday True
1522                         Exit Function
1523 
1524                     ' WindowPosition menu
1525                     Case Positionx0 To Positionx8
1526                         sWindowPosition wParam, hwnd
1527 
1528                     Case SingleClick
1529                         sClick True
1530                         Exit Function
1531 
1532                     Case DoubleClick
1533                         sClick False
1534                         Exit Function
1535 
1536                     Case 998
1537                         Call PostMessage(hwnd, WM_CLOSE, 0, 0)
1538                          lngLastMouseDown = 0
1539                         blMouseUp = False
1540                         Exit Function
1541 
1542                     Case Else
1543                         ' Call the Default Window Procedure for all other WM_COMMAND'
1544                         WindowProc = DefWindowProc(hwnd, message, wParam, lParam)
1545                         Exit Function
1546                 End Select
1547 
1548 
1549         Case Else
1550         'pass all other messages to default window procedure
1551         WindowProc = DefWindowProc(hwnd, message, wParam, lParam)
1552     End Select
1553 
1554 End Function
1555 
1556 Function GetFuncPtr(ByVal lngFnPtr As Long) As Long
1557     'wrapper function to allow AddressOf to be used within VB
1558     GetFuncPtr = lngFnPtr
1559 End Function
1560 
1561 Private Sub sDayState()
1562     ' Pass Dummy value for now
1563     mc.DAYSTATE = 0
1564 End Sub
1565 
1566 Private Function SetSelectedDate(ByVal dt As Date)
1567     SelectedDate = dt
1568 End Function
1569 
1570 Private Function SetMonths(ByVal mth As Integer)
1571 Dim ctr As Long
1572 Dim lTemp As Long
1573 Dim lRet As Long
1574 
1575     mc.SetViewableMonths mth
1576     'Exit Function
1577 
1578     ' 7 Possible/Total Menu Items to uncheck
1579     For ctr = 0 To 7
1580         lRet = CheckMenuItem(hMenuPop, ctr, MF_UNCHECKED Or MF_BYPOSITION)
1581     Next ctr
1582     ' Now set the Menu Check the current number of months displayed
1583     lTemp = (mc.MonthColumns * mc.MonthRows)
1584     Select Case lTemp
1585         Case 1
1586             ctr = 7
1587 
1588         Case 2
1589             ctr = 6
1590 
1591         Case 3
1592             ctr = 5
1593 
1594         Case 4
1595             ctr = 4
1596 
1597         Case 6
1598             ctr = 3
1599 
1600         Case 8
1601             ctr = 2
1602 
1603         Case 9
1604             ctr = 1
1605 
1606         Case 12
1607             ctr = 0
1608 
1609     End Select
1610 
1611     ' Now set the Menu Check
1612     lRet = CheckMenuItem(hMenuPop, ctr, MF_CHECKED Or MF_BYPOSITION)
1613 End Function
1614 
1615 
1616 Private Sub sClick(bl As Boolean)
1617     ' Sets the Class's OneClick property and the
1618     ' appropriate Menu Check Marks
1619     If bl Then
1620         mc.OneClick = True
1621         lngRet = CheckMenuItem(hMenuPopMiscOneClick, 0, MF_CHECKED Or MF_BYPOSITION)
1622         lngRet = CheckMenuItem(hMenuPopMiscOneClick, 1, MF_UNCHECKED Or MF_BYPOSITION)
1623     Else
1624         mc.OneClick = False
1625         lngRet = CheckMenuItem(hMenuPopMiscOneClick, 1, MF_CHECKED Or MF_BYPOSITION)
1626         lngRet = CheckMenuItem(hMenuPopMiscOneClick, 0, MF_UNCHECKED Or MF_BYPOSITION)
1627     End If
1628 End Sub
1629 
1630 Private Function ShowWeekNums(ByVal yn As Boolean)
1631     If yn = True Then
1632         mc.ShowWeekNumbers = True
1633         lngRet = CheckMenuItem(hMenuPopMiscShowWeekNumbers, 1, MF_CHECKED Or MF_BYPOSITION)
1634         lngRet = CheckMenuItem(hMenuPopMiscShowWeekNumbers, 0, MF_UNCHECKED Or MF_BYPOSITION)
1635     Else
1636         mc.ShowWeekNumbers = False
1637         lngRet = CheckMenuItem(hMenuPopMiscShowWeekNumbers, 0, MF_CHECKED Or MF_BYPOSITION)
1638         lngRet = CheckMenuItem(hMenuPopMiscShowWeekNumbers, 1, MF_UNCHECKED Or MF_BYPOSITION)
1639     End If
1640 End Function
1641 
1642 Private Sub ShowFontDialog()
1643     blDialogOpen = True
1644     mc.SelectFont
1645     blDialogOpen = False
1646 End Sub
1647 
1648 Private Sub SelectColor(ByVal index As Long)
1649     blDialogOpen = True
1650     mc.ChooseColors index
1651     blDialogOpen = False
1652 End Sub
1653 
1654 Private Sub ResetColors()
1655     mc.ResetCalendarColors
1656 End Sub
1657 
1658 Private Sub sShowToday(bl As Boolean)
1659     If bl Then
1660         mc.NoToday = True
1661         lngRet = CheckMenuItem(hMenuPopMiscToday, 0, MF_CHECKED Or MF_BYPOSITION)
1662         lngRet = CheckMenuItem(hMenuPopMiscToday, 1, MF_UNCHECKED Or MF_BYPOSITION)
1663     Else
1664         mc.NoToday = False
1665         lngRet = CheckMenuItem(hMenuPopMiscToday, 1, MF_CHECKED Or MF_BYPOSITION)
1666         lngRet = CheckMenuItem(hMenuPopMiscToday, 0, MF_UNCHECKED Or MF_BYPOSITION)
1667     End If
1668 End Sub
1669 
1670 Private Sub sShowcircleToday(bl As Boolean)
1671     If bl = True Then
1672         mc.NoTodayCircle = True
1673         lngRet = CheckMenuItem(hMenuPopMiscCircleToday, 0, MF_CHECKED Or MF_BYPOSITION)
1674         lngRet = CheckMenuItem(hMenuPopMiscCircleToday, 1, MF_UNCHECKED Or MF_BYPOSITION)
1675     Else
1676         lngRet = CheckMenuItem(hMenuPopMiscCircleToday, 1, MF_CHECKED Or MF_BYPOSITION)
1677         lngRet = CheckMenuItem(hMenuPopMiscCircleToday, 0, MF_UNCHECKED Or MF_BYPOSITION)
1678         mc.NoTodayCircle = False
1679     End If
1680 End Sub
1681 
1682 Private Sub sWindowPosition(wParam As Long, hwnd As Long)
1683 ' Position Window according to users Menu selections
1684 ' a) 0 -Pop at cursor location when user activates Calendar
1685 ' b) 1 -Where they manually move/leave it at
1686 ' c) 2 -Centered in Access App Window
1687 ' d) 3 -Centered on entire screen
1688 ' d) 4 -Top Left Corner
1689 
1690 Dim rc1 As RECT
1691 Dim pt As POINTAPI
1692 Dim lngRet As Long
1693 Dim ctr As Long
1694 Dim lTemp As Long
1695 
1696 
1697     Select Case wParam
1698 
1699         Case Positionx0
1700             ' Pop at Cursor
1701             mc.PositionAtCursor = True
1702 
1703         Case Positionx1
1704             mc.PositionAtCursor = False
1705             ' Use current position of Calendar Window
1706             ' Get rectangle for our Form
1707             'Debug.Print "GetWindowRect- Me.hWnd:" & m_Form.hWnd
1708             lngRet = GetWindowRect(hwnd, rc1)
1709 
1710             mc.CursorX = rc1.Left 'pt.x 'rc1.Left
1711             mc.CursorY = rc1.Top 'pt.y
1712 
1713         Case Positionx2 To Positionx8
1714             mc.PositionAtCursor = False
1715 
1716         Case Else
1717     End Select
1718 
1719     ' Update Window Position property
1720     mc.WindowLocation = wParam - 920
1721     'Debug.Print "modCalendar - mc.Windowlocation:" & wparam ' mc.WindowLocation
1722     For ctr = 0 To 4
1723         lngRet = CheckMenuItem(hMenuPopMiscWindowPosition, ctr, MF_UNCHECKED Or MF_BYPOSITION)
1724     Next ctr
1725     ' Now set the Menu Check the current number of months displayed
1726     lTemp = (mc.WindowLocation)
1727     ' Now set the Menu Check
1728     lngRet = CheckMenuItem(hMenuPopMiscWindowPosition, 4 - lTemp, MF_CHECKED Or MF_BYPOSITION)
1729 
1730     mc.ReDraw
1731 End Sub
1732 
1733 
1734 Private Sub KeysToMonthCal(ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long)
1735     Call PostMessage(ByVal mc.hWndCal, ByVal msg, ByVal wParam, ByVal lParam)
1736 End Sub
1737 
1738 Private Sub UpdateRangeVars(ByVal DateStart, ByVal DateEnd)
1739     localStartSelectedDate = DateStart
1740     localEndSelectedDate = DateEnd
1741 End Sub
1742 
1743 Private Sub UpdateCursor(ByVal lParam, ByVal hwnd As Long)
1744 'xPos = (int)(short) LOWORD(lParam);   // horizontal position
1745 'yPos = (int)(short) HIWORD(lParam);   // vertical position
1746 
1747 Dim pt As POINTAPI
1748 Dim rc As RECT
1749 Dim lRet As Long
1750 
1751     ' Should not happen
1752     If mc.hwnd = 0 Then Exit Sub
1753     ' Only update if the window is visible
1754     lRet = GetWindowLong(hwnd, GWL_STYLE)
1755     If Not (lRet And WS_VISIBLE) Then Exit Sub
1756 
1757     ' If PositionAtCursor is True then
1758     ' DO NOT UPDATE
1759     If mc.PositionAtCursor Then Exit Sub
1760 
1761     lngRet = GetWindowRect(hwnd, rc)
1762     pt.X = rc.Left
1763     pt.y = rc.Top
1764 
1765     'Debug.Print time & "  UpdateCursor -X:" & rc.Left & "  Y:" & rc.Top
1766     mc.CursorX = pt.X
1767     mc.CursorY = pt.y
1768 
1769     'UpdateCursor -X:" & mc.CursorX & "  Y:" & mc.CursorY
1770 End Sub
1771 
1772 
1773 Private Function LocationCursorOnCalendar(ByVal lParam As Long) As Boolean
1774 Dim ht As MCHITTESTINFO
1775     ' The x-coordinate of the cursor is the low-order word,
1776     ' and the y-coordinate of the cursor is the high-order word.
1777 
1778     ht.pt.X = LoWord(lParam)
1779     ht.pt.y = HiWord(lParam)
1780 
1781     ' Set structure size
1782     ht.cbSize = Len(ht)
1783     lngRet = apiSendMessage(ByVal mc.hWndCal, ByVal MCM_HITTEST, ByVal 0&, ht)
1784     If ht.uHit <> MCHT_CALENDARDATE Then
1785         LocationCursorOnCalendar = False
1786     Else
1787         LocationCursorOnCalendar = True
1788     End If
1789 End Function
1790 
1791 Private Function ReleaseClass()
1792     Set mc = Nothing
1793 End Function
1794 
1795 Private Function LoWord(ByVal DWord As Long) As Integer
1796     If DWord And &H8000& Then ' &H8000& = &H00008000
1797        LoWord = DWord Or &HFFFF0000
1798     Else
1799        LoWord = DWord And &HFFFF&
1800     End If
1801 End Function
1802 
1803 Private Function HiWord(ByVal DWord As Long) As Integer
1804     HiWord = (DWord And &HFFFF0000) \ &H10000
1805 End Function
1806 
1807 Function MakeDWord(LoWord As Integer, HiWord As Integer) As Long
1808     MakeDWord = (HiWord * &H10000) Or (LoWord And &HFFFF&)
1809 End Function
1810 
1811 
1812 
1813 
1814 
1815