************************************************** *-- Class: txtdate *-- ParentClass: textbox *-- Displays date in YL format and pops up calendar form from dblClick * Define Class txtdate As textbox Alignment = 3 Value = {} Format = "YL" Width = 120 *-- Sets the 'base' century to be used for date display. Two digits only ncentury = 19 *-- The year to be used for RollOver to the next century. Two digits nrollyear = 45 *-- Formatted character string used to save/restore default settings by the Set/Rest Cent methods ccentwas = "" Name = "txtdate" *-- Set Century and RollOver according to status of properties Procedure setcent Local lcCentWas, lcCentury, lcRollOn, lnRollYear, lnCentury With This *** Save Current settings Store '' To lcCentWas, lcCent, lcRollOn *** Century On/OFF lcCentWas = Padl( Set('Century'), 3) *** Base Century lcCentury = Padl( Set('Century',1), 2, '0' ) *** Rollover Year lcRollOn = Padl( Set('Century',2), 2, '0' ) *** Save off as character string .ccentwas = lcCentWas + lcCentury + lcRollOn *** If we have a specific RollOver Year use it, else default to current lnRollYear = Iif( !Empty( .nrollyear), .nrollyear, Int( Val( lcRollOn )) ) *** If we have a specific Century use it, else default to current lnCentury = Iif( !Empty( .ncentury ), .ncentury, Int( Val( lcCentury )) ) *** Set Century and Rollover Set Century To (lnCentury) ROLLOVER (lnRollYear) *** Force Century On Set Century On Endwith Endproc *-- Restore Century Settings from saved values Procedure restcent Local lcCentWas, lnCentury, lnRollOn Store '' To lcCentWas With This *** Read back the saved settings If ! Empty( .ccentwas ) lcCentWas = Alltrim( Substr( .ccentwas, 1, 3) ) lnCentury = Int( Val( Substr( .ccentwas, 4, 2) )) lnRollOn = Int( Val( Substr( .ccentwas, 6, 2) )) *** Set Century to default Set Century &lcCentWas *** Restore Original Settings Set Century To (lnCentury) ROLLOVER (lnRollOn) Endif Endwith Endproc *-- Called from dblClick to pop up the calendar form Procedure showcalendar Local luValue, lnTop, lnLeft *** Calculate where the popup calendar should be instantiated *** So it pops up directly below the date text box *** SYSMETRIC( 9 ) is the height of the Form's title bar in case you were curious lnTop = Objtoclient( Thisform, 1 ) + Objtoclient( This, 1 ) + This.Height + ; IIF( Thisform.TitleBar = 1, Sysmetric( 9 ) + 2, 2 ) lnLeft = Objtoclient( Thisform, 2 ) + Objtoclient( This, 2 ) Do Form GetDate With lnTop, lnLeft, This.Value To luValue This.Value = luValue Endproc Procedure LostFocus *** Restore Defaults This.restcent() DoDefault() Endproc Procedure GotFocus *** Set Century/Rollover This.setcent() DoDefault() Endproc Procedure DblClick This.showcalendar() Endproc EnddefineAnd here is the pop up calendar form:
************************************************** *-- Form: frmgetdate *-- ParentClass: form Define Class frmgetdate As Form Top = 0 Left = 0 Height = 363 Width = 376 Desktop = .T. ShowWindow = 1 DoCreate = .T. Caption = "Please select a date" Closable = .F. WindowType = 1 AlwaysOnTop = .T. *-- Return Value selected from the calendar tretval = {} *-- The date that the calendar has when the form is instantiated tinitialdate = {} Name = "frmGetDate" Add Object acxcalendar As acxcalendar With ; Top = 14, ; Left = 11, ; Height = 283, ; Width = 353, ; Name = "AcxCalendar" Add Object cmdok As cmdnotsobasic With ; Top = 309, ; Left = 109, ; Height = 39, ; Width = 77, ; FontSize = 14, ; Caption = "\<OK", ; Default = .T., ; Name = "cmdOK" Add Object cmdexit As cmdnotsobasic With ; Top = 309, ; Left = 190, ; Height = 39, ; Width = 77, ; FontSize = 14, ; Cancel = .T., ; Caption = "\<Cancel", ; Name = "cmdExit" *-- Called from the Init, sets up the position at which to display the calendar form Procedure SetForm Lparameters tnTop, tnLeft, tdInitialDate *** Initialize the combo with the passed date *** Default to today if empty With Thisform *** Position it correctly .Top = tnTop .Left = tnLeft *** Save the initial value so we can restore it if the user presses the cancel button .tinitialdate = tdInitialDate With .acxcalendar If Not Empty( tdInitialDate ) .Object.Value = tdInitialDate Else .Object.Value = Date() Endif Endwith Endwith Endproc Procedure Init Lparameters tnTop, tnLeft, tdInitialDate If DoDefault() Thisform.SetForm( tnTop, tnLeft, tdInitialDate ) Endif Endproc Procedure Unload Return Thisform.tretval Endproc Procedure cmdok.onclick With Thisform .tretval = Ttod( .acxcalendar.Object.Value ) .Release() Endwith Endproc Procedure cmdexit.onclick With Thisform .tretval = .tinitialdate .Release() Endwith Endproc EnddefineAnd finally, here is the calendar class:
************************************************** *-- Class: acxcalendar *-- ParentClass: olecontrol *-- OLEObject = C:\WINNT\System32\Mscal.ocx DEFINE CLASS acxcalendar AS olecontrol Height = 170 Width = 228 Name = "acxcalendar" ENDDEFINE