1 {
2 TDateTimePicker control for Lazarus
3 - - - - - - - - - - - - - - - - - - -
4 Author: Zoran Vučenović, January and February 2010
5         Зоран Вученовић, јануар и фебруар 2010.
6 
7    This unit is part of DateTimeCtrls package for Lazarus.
8 
9    Delphi's Visual Component Library (VCL) has a control named TDateTimePicker,
10 which I find very useful for editing dates. Lazarus Component Library (LCL),
11 however, does not have this control, because VCL wraps native Windows control
12 and it seems that such control does not exist on other platforms. Given that
13 LCL is designed to be platform independent, it could not use native Win control.
14    Instead, for editing dates LCL has a control named TDateEdit, but I prefer
15 the VCL's TDateTimePicker.
16    Therefore, I tried to create a custom control which would resemble VCL's
17 TDateTimePicker as much as possible, but not to rely on native Windows control.
18 
19    This TDateTimePicker control does not use native Win control. It has been
20 tested on Windows with win32/64 and qt widgetsets, as well as on Linux with
21 qt and gtk2 widgetsets.
22 
23 -----------------------------------------------------------
24 LICENCE
25 - - - -
26    Modified LGPL -- see the file COPYING.modifiedLGPL.
27 
28 -----------------------------------------------------------
29 NO WARRANTY
30 - - - - - -
31    There is no warranty whatsoever.
32 
33 -----------------------------------------------------------
34 BEST REGARDS TO LAZARUS COMMUNITY!
35 - - - - - - - - - - - - - - - - - -
36    I do hope this control will be useful.
37 }
38 unit DateTimePicker;
39 
40 {$mode objfpc}{$H+}
41 
42 interface
43 
44 uses
45   {$ifdef unix}
46   clocale, // needed to initialize default locale settings on Linux.
47   {$endif}
48   Classes, SysUtils, Controls, LCLType, Graphics, Math, StdCtrls, Buttons,
49   ExtCtrls, Forms, ComCtrls, Types, LMessages, Calendar, LazUTF8, LCLIntf,
50   LCLProc, Themes, CalControlWrapper;
51 
52 const
53   { We will deal with the NullDate value the special way. It will be especially
54     useful for dealing with null values from database. }
55   NullDate = TDateTime(Math.MaxDouble);
56 
57   { The biggest date a user can enter. }
58   TheBiggestDate = TDateTime(2958465.0); // 31. dec. 9999.
59 
60   { The smallest date a user can enter.
61     Note:
62       TCalendar does not accept smaller dates then 14. sep. 1752 on Windows OS
63       (see the implementation of TCustomCalendar.SetDateTime).
64       In Delphi help it is documented that Windows controls act weird with dates
65       older than 24. sep. 1752. Actually, TCalendar control has problems to show
66       dates before 1. okt. 1752. (try putting one calendar on the form, run the
67       application and see what september 1752. looks like).
68       Let's behave uniformely as much as
69       possible -- we won't allow dates before 1. okt. 1752. on any OS (who cares
70       about those).
71       So, this will be the down limit:  }
72   TheSmallestDate = TDateTime(-53780.0); // 1. okt. 1752.
73 
74 var
75   DefaultCalendarWrapperClass: TCalendarControlWrapperClass = nil;
76 
77 type
78   TYMD = record
79     Year, Month, Day: Word;
80   end;
81 
82   THMSMs = record
83     Hour, Minute, Second, MiliSec: Word;
84   end;
85 
86   { Used by DateDisplayOrder property to determine the order to display date
87     parts -- d-m-y, m-d-y or y-m-d.
88     When ddoTryDefault is set, the actual order is determined from
89     ShortDateFormat global variable -- see coments above
90     AdjustEffectiveDateDisplayOrder procedure }
91   TDateDisplayOrder = (ddoDMY, ddoMDY, ddoYMD, ddoTryDefault);
92 
93   TTimeDisplay = (tdHM,   // hour and minute
94                   tdHMS,  // hour, minute and second
95                   tdHMSMs // hour, minute, second and milisecond
96                   );
97 
98   TTimeFormat = (tf12, // 12 hours format, with am/pm string
99                  tf24  // 24 hours format
100                  );
101 
102   { TDateTimeKind determines if we should display date, time or both: }
103   TDateTimeKind = (dtkDate, dtkTime, dtkDateTime);
104 
105   TTextPart = 1..8;
106   TDateTimePart = (dtpDay, dtpMonth, dtpYear, dtpHour, dtpMinute,
107                                 dtpSecond, dtpMiliSec, dtpAMPM);
108   TDateTimeParts = set of dtpDay..dtpMiliSec; // without AMPM,
109            // because this set type is used for HideDateTimeParts property,
110            // where hiding of AMPM part is tied to hiding of hour (and, of
111            // course, it makes a difference only when TimeFormat is set to tf12)
112 
113   TArrowShape = (asClassicSmaller, asClassicLarger, asModernSmaller,
114     asModernLarger, asYetAnotherShape, asTheme);
115 
116   TDTDateMode = (dmComboBox, dmUpDown, dmNone);
117 
118   { calendar alignment - left or right,
119     dtaDefault means it is determined by BiDiMode }
120   TDTCalAlignment = (dtaLeft, dtaRight, dtaDefault);
121 
122   TDateTimePickerOption = (
123     dtpoDoChangeOnSetDateTime, dtpoEnabledIfUnchecked, dtpoAutoCheck, dtpoFlatButton);
124   TDateTimePickerOptions = set of TDateTimePickerOption;
125 
126   { TCustomDateTimePicker }
127 
128   TCustomDateTimePicker = class(TCustomControl)
129   private const
130     cDefOptions = [];
131     cCheckBoxBorder = 3;
132   private
133     FAutoAdvance: Boolean;
134     FAutoButtonSize: Boolean;
135     FCalAlignment: TDTCalAlignment;
136     FCalendarWrapperClass: TCalendarControlWrapperClass;
137     FCascade: Boolean;
138     FCenturyFrom, FEffectiveCenturyFrom: Word;
139     FChecked: Boolean;
140     FDateDisplayOrder: TDateDisplayOrder;
141     FHideDateTimeParts: TDateTimeParts;
142     FEffectiveHideDateTimeParts: set of TDateTimePart;
143     FKind: TDateTimeKind;
144     FLeadingZeros: Boolean;
145     FMonthNames: String;
146     FMonthNamesArray: TMonthNameArray;
147     FNullInputAllowed: Boolean;
148     FDateTime: TDateTime;
149     FDateSeparator: String;
150     FReadOnly: Boolean;
151     FMaxDate, FMinDate: TDate;
152     FShowMonthNames: Boolean;
153     FTextForNullDate: TCaption;
154     FTimeSeparator: String;
155     FTimeDisplay: TTimeDisplay;
156     FTimeFormat: TTimeFormat;
157     FTrailingSeparator: Boolean;
158     FUseDefaultSeparators: Boolean;
159     FUserChangedText: Boolean;
160     FYearPos, FDayPos, FMonthPos: 1..3;
161     FTextPart: array[1..3] of String;
162     FTimeText: array[dtpHour..dtpAMPM] of String;
163     FUserChanging: Integer;
164     FDigitWidth: Integer;
165     FTextHeight: Integer;
166     FSeparatorWidth: Integer;
167     FSepNoSpaceWidth: Integer;
168     FShowCheckBox: Boolean;
169     FMouseInCheckBox: Boolean;
170     FTimeSeparatorWidth: Integer;
171     FMonthWidth: Integer;
172     FNullMonthText: String;
173     FSelectedTextPart: TTextPart;
174     FRecalculatingTextSizesNeeded: Boolean;
175     FJumpMinMax: Boolean;
176     FAMPMWidth: Integer;
177     FDateWidth: Integer;
178     FTimeWidth: Integer;
179     FTextWidth: Integer;
180     FArrowShape: TArrowShape;
181     FDateMode: TDTDateMode;
182     FTextEnabled: Boolean;
183     FUpDown: TCustomUpDown;
184     FOnChange: TNotifyEvent;
185     FOnCheckBoxChange: TNotifyEvent;
186     FOnChangeHandlers: TMethodList;
187     FOnCheckBoxChangeHandlers: TMethodList;
188     FOnDropDown: TNotifyEvent;
189     FOnCloseUp: TNotifyEvent;
190     FEffectiveDateDisplayOrder: TDateDisplayOrder;
191 
192     FArrowButton: TCustomSpeedButton;
193     FCalendarForm: TCustomForm;
194     FDoNotArrangeControls: Boolean;
195     FConfirmedDateTime: TDateTime;
196     FNoEditingDone: Integer;
197     FAllowDroppingCalendar: Boolean;
198     FCorrectedDTP: TDateTimePart;
199     FCorrectedValue: Word;
200     FSkipChangeInUpdateDate: Integer;
201     FOptions: TDateTimePickerOptions;
202 
AreSeparatorsStorednull203     function AreSeparatorsStored: Boolean;
GetCheckednull204     function GetChecked: Boolean;
GetDatenull205     function GetDate: TDate;
GetDateTimenull206     function GetDateTime: TDateTime;
GetDroppedDownnull207     function GetDroppedDown: Boolean;
GetTimenull208     function GetTime: TTime;
209     procedure SetArrowShape(const AValue: TArrowShape);
210     procedure SetAutoButtonSize(AValue: Boolean);
211     procedure SetCalAlignment(AValue: TDTCalAlignment);
212     procedure SetCalendarWrapperClass(AValue: TCalendarControlWrapperClass);
213     procedure SetCenturyFrom(const AValue: Word);
214     procedure SetChecked(const AValue: Boolean);
215     procedure CheckTextEnabled;
216     procedure SetDateDisplayOrder(const AValue: TDateDisplayOrder);
217     procedure SetDateMode(const AValue: TDTDateMode);
218     procedure SetHideDateTimeParts(AValue: TDateTimeParts);
219     procedure SetKind(const AValue: TDateTimeKind);
220     procedure SetLeadingZeros(const AValue: Boolean);
221     procedure SetMonthNames(AValue: String);
222     procedure SetNullInputAllowed(const AValue: Boolean);
223     procedure SetDate(const AValue: TDate);
224     procedure SetDateTime(const AValue: TDateTime);
225     procedure SetDateSeparator(const AValue: String);
226     procedure SetMaxDate(const AValue: TDate);
227     procedure SetMinDate(const AValue: TDate);
228     procedure SetReadOnly(const AValue: Boolean);
229     procedure SetShowCheckBox(const AValue: Boolean);
230     procedure SetShowMonthNames(AValue: Boolean);
231     procedure SetTextForNullDate(const AValue: TCaption);
232     procedure SetTime(const AValue: TTime);
233     procedure SetTimeSeparator(const AValue: String);
234     procedure SetTimeDisplay(const AValue: TTimeDisplay);
235     procedure SetTimeFormat(const AValue: TTimeFormat);
236     procedure SetTrailingSeparator(const AValue: Boolean);
237     procedure SetUseDefaultSeparators(const AValue: Boolean);
238 
GetHournull239     function GetHour: Word;
GetMiliSecnull240     function GetMiliSec: Word;
GetMinutenull241     function GetMinute: Word;
GetSecondnull242     function GetSecond: Word;
243     procedure RecalculateTextSizesIfNeeded;
GetDaynull244     function GetDay: Word;
GetMonthnull245     function GetMonth: Word;
GetYearnull246     function GetYear: Word;
GetHMSMsnull247     function GetHMSMs(const NowIfNull: Boolean = False): THMSMs;
GetYYYYMMDDnull248     function GetYYYYMMDD(const TodayIfNull: Boolean = False;
249                                const WithCorrection: Boolean = False): TYMD;
250     procedure SetHour(const AValue: Word);
251     procedure SetMiliSec(const AValue: Word);
252     procedure SetMinute(const AValue: Word);
253     procedure SetSecond(const AValue: Word);
254     procedure SetSeparators(const DateSep, TimeSep: String);
255     procedure SetDay(const AValue: Word);
256     procedure SetMonth(const AValue: Word);
257     procedure SetYear(const AValue: Word);
258     procedure SetYYYYMMDD(const AValue: TYMD);
259     procedure SetHMSMs(const AValue: THMSMs);
260     procedure UpdateIfUserChangedText;
GetSelectedTextnull261     function GetSelectedText: String;
262     procedure AdjustSelection;
263     procedure AdjustEffectiveCenturyFrom;
264     procedure AdjustEffectiveDateDisplayOrder;
265     procedure AdjustEffectiveHideDateTimeParts;
266     procedure SelectDateTimePart(const DateTimePart: TDateTimePart);
267     procedure MoveSelectionLR(const ToLeft: Boolean);
268     procedure DestroyCalendarForm;
269     procedure DropDownCalendarForm;
270     procedure UpdateShowArrowButton;
271     procedure DestroyUpDown;
272     procedure DestroyArrowBtn;
273     procedure ArrowMouseDown(Sender: TObject; Button: TMouseButton;
274                                             Shift: TShiftState; X, Y: Integer);
275     procedure UpDownClick(Sender: TObject; Button: TUDBtnType);
276     procedure SetFocusIfPossible;
277     procedure AutoResizeButton;
278     procedure CheckAndApplyKey(const Key: Char);
279     procedure CheckAndApplyKeyCode(var Key: Word);
280     procedure SetOptions(const aOptions: TDateTimePickerOptions);
281 
282   protected
283     procedure WMKillFocus(var Message: TLMKillFocus); message LM_KILLFOCUS;
284     procedure WMSize(var Message: TLMSize); message LM_SIZE;
285 
GetControlClassDefaultSizenull286     class function GetControlClassDefaultSize: TSize; override;
287 
288     procedure ConfirmChanges; virtual;
289     procedure UndoChanges; virtual;
290 
GetCheckBoxRectnull291     function GetCheckBoxRect(IgnoreRightToLeft: Boolean = False): TRect;
GetDateTimePartFromTextPartnull292     function GetDateTimePartFromTextPart(TextPart: TTextPart): TDateTimePart;
GetSelectedDateTimePartnull293     function GetSelectedDateTimePart: TDateTimePart;
294     procedure FontChanged(Sender: TObject); override;
GetTextOriginnull295     function GetTextOrigin(IgnoreRightToLeft: Boolean = False): TPoint;
296     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
297     procedure KeyPress(var Key: char); override;
298     procedure SelectTextPartUnderMouse(XMouse: Integer);
299     procedure MouseLeave; override;
300     procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
301     procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
DoMouseWheelnull302     function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; override;
303     procedure UpdateDate(const CallChangeFromSetDateTime: Boolean = False); virtual;
304     procedure DoEnter; override;
305     procedure DoExit; override;
306     procedure Click; override;
307     procedure DblClick; override;
308     procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
309     procedure KeyUp(var Key: Word; Shift: TShiftState); override;
310     procedure UTF8KeyPress(var UTF8Key: TUTF8Char); override;
311     procedure CalculatePreferredSize(var PreferredWidth,
312                   PreferredHeight: integer; WithThemeSpace: Boolean); override;
313     procedure SetBiDiMode(AValue: TBiDiMode); override;
314 
315     procedure IncreaseCurrentTextPart;
316     procedure DecreaseCurrentTextPart;
317     procedure IncreaseMonth;
318     procedure IncreaseYear;
319     procedure IncreaseDay;
320     procedure DecreaseMonth;
321     procedure DecreaseYear;
322     procedure DecreaseDay;
323     procedure IncreaseHour;
324     procedure IncreaseMinute;
325     procedure IncreaseSecond;
326     procedure IncreaseMiliSec;
327     procedure DecreaseHour;
328     procedure DecreaseMinute;
329     procedure DecreaseSecond;
330     procedure DecreaseMiliSec;
331     procedure ChangeAMPM;
332 
333     procedure SelectDay;
334     procedure SelectMonth;
335     procedure SelectYear;
336     procedure SelectHour;
337     procedure SelectMinute;
338     procedure SelectSecond;
339     procedure SelectMiliSec;
340     procedure SelectAMPM;
341 
342     procedure SetEnabled(Value: Boolean); override;
343     procedure SetAutoSize(Value: Boolean); override;
344     procedure CreateWnd; override;
345     procedure SetDateTimeJumpMinMax(const AValue: TDateTime);
346     procedure ArrangeCtrls; virtual;
347     procedure Change; virtual;
348     procedure CheckBoxChange; virtual;
349     procedure DoDropDown; virtual;
350     procedure DoCloseUp; virtual;
351     procedure DoAutoCheck; virtual;
352     procedure DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy;
353       const AXProportion, AYProportion: Double); override;
354 
355     procedure AddHandlerOnChange(const AOnChange: TNotifyEvent;
356       AsFirst: Boolean = False); virtual;
357     procedure AddHandlerOnCheckBoxChange(const AOnCheckBoxChange: TNotifyEvent;
358       AsFirst: Boolean = False); virtual;
359     procedure RemoveHandlerOnChange(AOnChange: TNotifyEvent); virtual;
360     procedure RemoveHandlerOnCheckBoxChange(AOnCheckBoxChange: TNotifyEvent); virtual;
361 
362     property BorderStyle default bsSingle;
363     property AutoSize default True;
364     property TabStop default True;
365     property ParentColor default False;
366     property CenturyFrom: Word
367              read FCenturyFrom write SetCenturyFrom;
368     property DateDisplayOrder: TDateDisplayOrder
369              read FDateDisplayOrder write SetDateDisplayOrder default ddoTryDefault;
370     property MaxDate: TDate
371              read FMaxDate write SetMaxDate;
372     property MinDate: TDate
373              read FMinDate write SetMinDate;
374     property DateTime: TDateTime read GetDateTime write SetDateTime;
375     property TrailingSeparator: Boolean
376              read FTrailingSeparator write SetTrailingSeparator;
377     property ReadOnly: Boolean read FReadOnly write SetReadOnly default False;
378     property LeadingZeros: Boolean read FLeadingZeros write SetLeadingZeros;
379     property TextForNullDate: TCaption
380              read FTextForNullDate write SetTextForNullDate;
381     property NullInputAllowed: Boolean
382              read FNullInputAllowed write SetNullInputAllowed default True;
383     property OnChange: TNotifyEvent read FOnChange write FOnChange;
384     property OnCheckBoxChange: TNotifyEvent
385              read FOnCheckBoxChange write FOnCheckBoxChange;
386     property OnDropDown: TNotifyEvent read FOnDropDown write FOnDropDown;
387     property OnCloseUp: TNotifyEvent read FOnCloseUp write FOnCloseUp;
388     property ShowCheckBox: Boolean
389              read FShowCheckBox write SetShowCheckBox default False;
390     property Checked: Boolean read GetChecked write SetChecked default True;
391     property ArrowShape: TArrowShape
392              read FArrowShape write SetArrowShape default asTheme;
393     property Kind: TDateTimeKind
394              read FKind write SetKind;
395     property DateSeparator: String
396              read FDateSeparator write SetDateSeparator stored AreSeparatorsStored;
397     property TimeSeparator: String
398              read FTimeSeparator write SetTimeSeparator stored AreSeparatorsStored;
399     property UseDefaultSeparators: Boolean
400              read FUseDefaultSeparators write SetUseDefaultSeparators;
401     property TimeFormat: TTimeFormat read FTimeFormat write SetTimeFormat;
402     property TimeDisplay: TTimeDisplay read FTimeDisplay write SetTimeDisplay;
403     property Time: TTime read GetTime write SetTime;
404     property Date: TDate read GetDate write SetDate;
405     property DateMode: TDTDateMode read FDateMode write SetDateMode;
406     property Cascade: Boolean read FCascade write FCascade default False;
407     property AutoButtonSize: Boolean
408              read FAutoButtonSize write SetAutoButtonSize default False;
409     property AutoAdvance: Boolean
410              read FAutoAdvance write FAutoAdvance default True;
411     property HideDateTimeParts: TDateTimeParts
412              read FHideDateTimeParts write SetHideDateTimeParts;
413     property CalendarWrapperClass: TCalendarControlWrapperClass
414              read FCalendarWrapperClass write SetCalendarWrapperClass;
415     property MonthNames: String read FMonthNames write SetMonthNames;
416     property ShowMonthNames: Boolean
417              read FShowMonthNames write SetShowMonthNames default False;
418     property DroppedDown: Boolean read GetDroppedDown;
419     property CalAlignment: TDTCalAlignment read FCalAlignment write SetCalAlignment default dtaDefault;
420     property Options: TDateTimePickerOptions read FOptions write SetOptions default cDefOptions;
421   public
422     constructor Create(AOwner: TComponent); override;
423     destructor Destroy; override;
DateIsNullnull424     function DateIsNull: Boolean;
425     procedure SelectDate;
426     procedure SelectTime;
427     procedure SendExternalKey(const aKey: Char);
428     procedure SendExternalKeyCode(const Key: Word);
429     procedure RemoveAllHandlersOfObject(AnObject: TObject); override;
430 
431     procedure Paint; override;
432     procedure EditingDone; override;
433 
434   published
435     //
436   end;
437 
438   {TDateTimePicker}
439 
440   TDateTimePicker = class(TCustomDateTimePicker)
441   public
442     procedure AddHandlerOnChange(const AOnChange: TNotifyEvent; AsFirst: Boolean = False
443       ); override;
444     procedure AddHandlerOnCheckBoxChange(const AOnCheckBoxChange: TNotifyEvent;
445       AsFirst: Boolean = False); override;
446     procedure RemoveHandlerOnChange(AOnChange: TNotifyEvent); override;
447     procedure RemoveHandlerOnCheckBoxChange(AOnCheckBoxChange: TNotifyEvent); override;
448   public
449     property DateTime;
450     property CalendarWrapperClass;
451     property DroppedDown;
452   published
453     property ArrowShape;
454     property ShowCheckBox;
455     property Checked;
456     property CenturyFrom;
457     property DateDisplayOrder;
458     property MaxDate;
459     property MinDate;
460     property ReadOnly;
461     property AutoSize;
462     property Font;
463     property ParentFont;
464     property TabOrder;
465     property TabStop;
466     property BorderStyle;
467     property BorderSpacing;
468     property Enabled;
469     property Color;
470     property ParentColor;
471     property DateSeparator;
472     property TrailingSeparator;
473     property TextForNullDate;
474     property LeadingZeros;
475     property ShowHint;
476     property ParentShowHint;
477     property Align;
478     property Anchors;
479     property Constraints;
480     property Cursor;
481     property PopupMenu;
482     property Visible;
483     property NullInputAllowed;
484     property Kind;
485     property TimeSeparator;
486     property TimeFormat;
487     property TimeDisplay;
488     property DateMode;
489     property Date;
490     property Time;
491     property UseDefaultSeparators;
492     property Cascade;
493     property AutoButtonSize;
494     property AutoAdvance;
495     property HideDateTimeParts;
496     property BiDiMode;
497     property ParentBiDiMode;
498     property MonthNames;
499     property ShowMonthNames;
500     property CalAlignment;
501     property Options;
502 // events:
503     property OnChange;
504     property OnCheckBoxChange;
505     property OnDropDown;
506     property OnCloseUp;
507     property OnChangeBounds;
508     property OnClick;
509     property OnContextPopup;
510     property OnDblClick;
511     property OnEditingDone;
512     property OnEnter;
513     property OnExit;
514     property OnKeyDown;
515     property OnKeyPress;
516     property OnKeyUp;
517     property OnMouseDown;
518     property OnMouseEnter;
519     property OnMouseLeave;
520     property OnMouseMove;
521     property OnMouseUp;
522     property OnMouseWheel;
523     property OnMouseWheelDown;
524     property OnMouseWheelUp;
525     property OnResize;
526     property OnUTF8KeyPress;
527   end;
528 
EqualDateTimenull529 function EqualDateTime(const A, B: TDateTime): Boolean;
IsNullDatenull530 function IsNullDate(DT: TDateTime): Boolean;
531 
532 implementation
533 
534 uses
535   DateUtils, LCLCalWrapper;
536 
537 const
538   DefaultUpDownWidth = 15;
539   DefaultArrowButtonWidth = DefaultUpDownWidth + 2;
540 
NumberOfDaysInMonthnull541 function NumberOfDaysInMonth(const Month, Year: Word): Word;
542 begin
543   Result := 0;
544   if Month in [1..12] then
545     Result := MonthDays[IsLeapYear(Year), Month];
546 end;
547 
548 { EqualDateTime
549   --------------
550   Returns True when two dates are equal or both are null }
EqualDateTimenull551 function EqualDateTime(const A, B: TDateTime): Boolean;
552 begin
553   if IsNullDate(A) then
554     Result := IsNullDate(B)
555   else
556     Result := (not IsNullDate(B)) and (A = B);
557 end;
558 
IsNullDatenull559 function IsNullDate(DT: TDateTime): Boolean;
560 begin
561   Result := IsNan(DT) or IsInfinite(DT) or
562             (DT > SysUtils.MaxDateTime) or (DT < SysUtils.MinDateTime);
563 end;
564 
565 type
566 
567   { TDTUpDown }
568 
569 { The two buttons contained by UpDown control are never disabled in original
570   UpDown class. This class is defined here to override this behaviour. }
571   TDTUpDown = class(TCustomUpDown)
572   private
573     DTPicker: TCustomDateTimePicker;
574   protected
575     procedure SetEnabled(Value: Boolean); override;
576     procedure CalculatePreferredSize(var PreferredWidth,
577                   PreferredHeight: integer; WithThemeSpace: Boolean); override;
578     procedure WndProc(var Message: TLMessage); override;
579   end;
580 
581   { TDTSpeedButton }
582 
583   TDTSpeedButton = class(TCustomSpeedButton)
584   private
585     DTPicker: TCustomDateTimePicker;
586   protected
587     procedure CalculatePreferredSize(var PreferredWidth,
588                   PreferredHeight: integer; WithThemeSpace: Boolean); override;
589     procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
590       override;
591   public
592     procedure Paint; override;
593   end;
594 
595   { TDTCalendarForm }
596 
597   TDTCalendarForm = class(TForm)
598   private
599     DTPicker: TCustomDateTimePicker;
600     Cal: TCalendarControlWrapper;
601     Shape: TShape;
602     RememberedCalendarFormOrigin: TPoint;
603     FClosing: Boolean;
604     DTPickersParentForm: TCustomForm;
605 
606     procedure SetClosingCalendarForm;
607     procedure AdjustCalendarFormSize;
608     procedure AdjustCalendarFormScreenPosition;
609     procedure CloseCalendarForm(const AndSetTheDate: Boolean = False);
610 
611     procedure CalendarKeyDown(Sender: TObject; var Key: Word;
612                                       Shift: TShiftState);
613     procedure CalendarResize(Sender: TObject);
614     procedure CalendarClick(Sender: TObject);
615     procedure VisibleOfParentChanged(Sender: TObject);
616 
617   protected
618     procedure Deactivate; override;
619     procedure DoShow; override;
620     procedure DoClose(var CloseAction: TCloseAction); override;
621     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
622 
623     procedure WMActivate(var Message: TLMActivate); message LM_ACTIVATE;
624   public
625     constructor CreateNewDTCalendarForm(AOwner: TComponent;
626                   ADTPicker: TCustomDateTimePicker);
627     destructor Destroy; override;
628   published
629   end;
630 
631 { TDateTimePicker }
632 
633 procedure TDateTimePicker.AddHandlerOnChange(const AOnChange: TNotifyEvent;
634   AsFirst: Boolean);
635 begin
636   inherited AddHandlerOnChange(AOnChange, AsFirst);
637 end;
638 
639 procedure TDateTimePicker.AddHandlerOnCheckBoxChange(
640   const AOnCheckBoxChange: TNotifyEvent; AsFirst: Boolean);
641 begin
642   inherited AddHandlerOnCheckBoxChange(AOnCheckBoxChange, AsFirst);
643 end;
644 
645 procedure TDateTimePicker.RemoveHandlerOnChange(AOnChange: TNotifyEvent);
646 begin
647   inherited RemoveHandlerOnChange(AOnChange);
648 end;
649 
650 procedure TDateTimePicker.RemoveHandlerOnCheckBoxChange(
651   AOnCheckBoxChange: TNotifyEvent);
652 begin
653   inherited RemoveHandlerOnCheckBoxChange(AOnCheckBoxChange);
654 end;
655 
656 procedure TDTCalendarForm.SetClosingCalendarForm;
657 begin
658   if not FClosing then begin
659     FClosing := True;
660 
661     if Assigned(DTPicker) and (DTPicker.FCalendarForm = Self) then
662       DTPicker.FCalendarForm := nil;
663 
664   end;
665 end;
666 
667 procedure TDTCalendarForm.AdjustCalendarFormSize;
668 begin
669   if not FClosing then begin
670     ClientWidth := Cal.GetCalendarControl.Width + 2;
671     ClientHeight := Cal.GetCalendarControl.Height + 2;
672 
673     Shape.SetBounds(0, 0, ClientWidth, ClientHeight);
674 
675     AdjustCalendarFormScreenPosition;
676 
677   end;
678 end;
679 
680 procedure TDTCalendarForm.AdjustCalendarFormScreenPosition;
681 var
682   M: TMonitor;
683   R: TRect;
684   P: TPoint;
685   H, W: Integer;
686 begin
687   H := Height;
688   W := Width;
689 
690   if (DTPicker.CalAlignment = dtaRight) or
691         ((DTPicker.CalAlignment = dtaDefault) and IsRightToLeft) then
692     P := DTPicker.ControlToScreen(Point(DTPicker.Width - W, DTPicker.Height))
693   else
694     P := DTPicker.ControlToScreen(Point(0, DTPicker.Height));
695 
696   M := Screen.MonitorFromWindow(DTPicker.Handle);
697 
698   R := M.WorkareaRect;
699   // WorkareaRect sometimes is not implemented (gtk2?). Depends on widgetset
700   // and window manager or something like that. Then it returns (0,0,0,0) and
701   // the best we can do is use BoundsRect instead:
702   if (R.Right <= R.Left) or (R.Bottom <= R.Top) then
703     R := M.BoundsRect;
704 
705   if P.y > R.Bottom - H then
706     P.y := P.y - H - DTPicker.Height;
707 
708   if P.y < R.Top then
709     P.y := R.Top;
710 
711   if P.x > R.Right - W then
712     P.x := R.Right - W;
713 
714   if P.x < R.Left then
715     P.x := R.Left;
716 
717   if (P.x <> RememberedCalendarFormOrigin.x)
718             or (P.y <> RememberedCalendarFormOrigin.y) then begin
719     SetBounds(P.x, P.y, W, H);
720     RememberedCalendarFormOrigin := P;
721   end;
722 
723 end;
724 
725 procedure TDTCalendarForm.CloseCalendarForm(const AndSetTheDate: Boolean);
726 begin
727   if not FClosing then
728     try
729       SetClosingCalendarForm;
730       Visible := False;
731 
732       if Assigned(DTPicker) and DTPicker.IsVisible then begin
733 
734         if AndSetTheDate then begin
735           Inc(DTPicker.FUserChanging);
736           try
737             if DTPicker.DateIsNull then begin
738               // we'll set the time to 0.0 (midnight):
739               DTPicker.SetDateTime(Int(Cal.GetDate));
740             end else if not EqualDateTime(Int(DTPicker.DateTime),
741                                           Int(Cal.GetDate)) then begin
742               // we'll change the date, but keep the time:
743               DTPicker.SetDateTime(ComposeDateTime(Cal.GetDate, DTPicker.DateTime));
744             end;
745             DTPicker.DoAutoCheck;
746           finally
747             Dec(DTPicker.FUserChanging);
748           end;
749         end;
750 
751         if Screen.ActiveCustomForm = Self then
752           DTPicker.SetFocusIfPossible;
753 
754         DTPicker.DoCloseUp;
755       end;
756 
757     finally
758       Release;
759     end;
760 
761 end;
762 
763 procedure TDTCalendarForm.CalendarKeyDown(Sender: TObject; var Key: Word;
764   Shift: TShiftState);
765 begin
766   if (not(Cal.GetCalendarControl is TCustomCalendar))
767        or (TCustomCalendar(Cal.GetCalendarControl).GetCalendarView = cvMonth) then
768     case Key of
769       VK_ESCAPE:
770         CloseCalendarForm;
771 
772       VK_RETURN, VK_SPACE:
773         CloseCalendarForm(True);
774 
775     end;
776 end;
777 
778 procedure TDTCalendarForm.CalendarResize(Sender: TObject);
779 begin
780   AdjustCalendarFormSize;
781 end;
782 
783 procedure TDTCalendarForm.CalendarClick(Sender: TObject);
784 var
785   P: TPoint;
786 begin
787   P := Cal.GetCalendarControl.ScreenToClient(Mouse.CursorPos);
788   if Cal.AreCoordinatesOnDate(P.x, P.y) then
789      CloseCalendarForm(True);
790 
791 end;
792 
793 { This procedure is added to list of "visible change handlers" of DTPicker's
794   parent form, so that hiding of DTPicker's parent form does not leave the
795   calendar form visible. }
796 procedure TDTCalendarForm.VisibleOfParentChanged(Sender: TObject);
797 begin
798   SetClosingCalendarForm;
799   Release;
800 end;
801 
802 procedure TDTCalendarForm.WMActivate(var Message: TLMActivate);
803 var
804   PP: HWND;
805 begin
806   inherited;
807 
808   PP := LCLIntf.GetParent(Handle);
809   if (PP<>0) then
810     SendMessage(PP, LM_NCACTIVATE, Ord(Message.Active <> WA_INACTIVE), 0);
811 end;
812 
813 procedure TDTCalendarForm.Notification(AComponent: TComponent;
814   Operation: TOperation);
815 begin
816   inherited Notification(AComponent, Operation);
817 
818   if (AComponent = DTPickersParentForm) and (Operation = opRemove) then
819     DTPickersParentForm := nil;
820 
821 end;
822 
823 procedure TDTCalendarForm.Deactivate;
824 begin
825   inherited Deactivate;
826 
827   CloseCalendarForm;
828 end;
829 
830 procedure TDTCalendarForm.DoShow;
831 begin
832   if not FClosing then begin
833     inherited DoShow;
834 
835     AdjustCalendarFormSize;
836     DTPicker.DoDropDown; // calls OnDropDown event handler
837   end;
838 end;
839 
840 procedure TDTCalendarForm.DoClose(var CloseAction: TCloseAction);
841 begin
842   SetClosingCalendarForm;
843   CloseAction := caFree;
844 
845   inherited DoClose(CloseAction);
846 end;
847 
848 constructor TDTCalendarForm.CreateNewDTCalendarForm(AOwner: TComponent;
849   ADTPicker: TCustomDateTimePicker);
850 var
851   P: TPoint;
852   CalClass: TCalendarControlWrapperClass;
853 begin
854   inherited CreateNew(AOwner);
855 
856   ADTPicker.FAllowDroppingCalendar := False;
857   FClosing := False;
858 
859   DTPicker := ADTPicker;
860   BiDiMode := DTPicker.BiDiMode;
861   DTPickersParentForm := GetParentForm(DTPicker);
862   if Assigned(DTPickersParentForm) then begin
863     DTPickersParentForm.AddHandlerOnVisibleChanged(@VisibleOfParentChanged);
864     DTPickersParentForm.FreeNotification(Self);
865   end;
866   PopupMode := pmAuto;
867 
868   P := Point(0, 0);
869 
870   if ADTPicker.FCalendarWrapperClass = nil then begin
871     if DefaultCalendarWrapperClass = nil then
872       CalClass := TLCLCalendarWrapper
873     else
874       CalClass := DefaultCalendarWrapperClass;
875   end else
876     CalClass := ADTPicker.FCalendarWrapperClass;
877 
878   Cal := CalClass.Create;
879 
880   Cal.GetCalendarControl.ParentBiDiMode := True;
881   Cal.GetCalendarControl.AutoSize := True;
882   Cal.GetCalendarControl.GetPreferredSize(P.x, P.y);
883   Cal.GetCalendarControl.Align := alNone;
884   Cal.GetCalendarControl.SetBounds(1, 1, P.x, P.y);
885 
886   SetBounds(-8000, -8000, P.x + 2, P.y + 2);
887   RememberedCalendarFormOrigin := Point(-8000, -8000);
888 
889   ShowInTaskBar := stNever;
890   BorderStyle := bsNone;
891 
892   Shape := TShape.Create(nil);
893   Shape.Brush.Style := bsClear;
894 
895   if DTPicker.DateIsNull then
896     Cal.SetDate(Max(DTPicker.MinDate, Min(SysUtils.Date, DTPicker.MaxDate)))
897 
898   else if DTPicker.DateTime < DTPicker.MinDate then // These "out of bounds" values
899     Cal.SetDate(DTPicker.MinDate)      // can happen when DateTime was set with
900   else if DTPicker.DateTime > DTPicker.MaxDate then // "SetDateTimeJumpMinMax" protected
901     Cal.SetDate(DTPicker.MaxDate)      // procedure (used in TDBDateTimePicker control).
902 
903   else
904     Cal.SetDate(DTPicker.Date);
905 
906   Cal.GetCalendarControl.OnResize := @CalendarResize;
907   Cal.GetCalendarControl.OnClick := @CalendarClick;
908   if Cal.GetCalendarControl is TWinControl then begin
909     TWinControl(Cal.GetCalendarControl).OnKeyDown := @CalendarKeyDown;
910     TWinControl(Cal.GetCalendarControl).TabStop := True;
911     TWinControl(Cal.GetCalendarControl).SetFocus;
912   end;
913 
914   Shape.Parent := Self;
915   Cal.GetCalendarControl.Parent := Self;
916   Cal.GetCalendarControl.BringToFront;
917 end;
918 
919 destructor TDTCalendarForm.Destroy;
920 begin
921   SetClosingCalendarForm;
922   if Assigned(DTPickersParentForm) then
923     DTPickersParentForm.RemoveAllHandlersOfObject(Self);
924 
925   if Assigned(Cal) then begin
926     Cal.GetCalendarControl.OnResize := nil;
927     Cal.GetCalendarControl.OnClick := nil;
928     if Cal.GetCalendarControl is TWinControl then
929       TWinControl(Cal.GetCalendarControl).OnKeyDown := nil;
930     Cal.Free;
931     Cal := nil;
932   end;
933   FreeAndNil(Shape);
934 
935   if Assigned(DTPicker) then begin
936     if (Screen.ActiveControl = DTPicker) then
937       DTPicker.Invalidate;
938 
939     if DTPicker.FCalendarForm = nil then
940       DTPicker.FAllowDroppingCalendar := True;
941 
942   end;
943 
944   inherited Destroy;
945 end;
946 
947 { TCustomDateTimePicker }
948 
949 procedure TCustomDateTimePicker.SetChecked(const AValue: Boolean);
950 begin
951   if (FChecked=AValue) or not FShowCheckBox then
952     Exit;
953   FChecked := AValue;
954 
955   CheckBoxChange;
956   CheckTextEnabled;
957   Invalidate;
958 end;
959 
960 procedure TCustomDateTimePicker.CheckTextEnabled;
961 begin
962   FTextEnabled := Self.Enabled and ((dtpoEnabledIfUnchecked in Options) or GetChecked);
963 
964   if Assigned(FArrowButton) then
965     FArrowButton.Enabled := FTextEnabled;
966 
967   if Assigned(FUpDown) then
968     FUpDown.Enabled := FTextEnabled;
969 end;
970 
971 procedure TCustomDateTimePicker.SetDateDisplayOrder(
972   const AValue: TDateDisplayOrder);
973 var
974   PreviousEffectiveDDO: TDateDisplayOrder;
975 begin
976   if FDateDisplayOrder <> AValue then begin
977     PreviousEffectiveDDO := FEffectiveDateDisplayOrder;
978     FDateDisplayOrder := AValue;
979     AdjustEffectiveDateDisplayOrder;
980     if FEffectiveDateDisplayOrder <> PreviousEffectiveDDO then begin
981       AdjustSelection;
982       UpdateDate;
983     end;
984   end;
985 end;
986 
987 procedure TCustomDateTimePicker.SetDateMode(const AValue: TDTDateMode);
988 begin
989   FDateMode := AValue;
990   UpdateShowArrowButton;
991 end;
992 
993 procedure TCustomDateTimePicker.SetHideDateTimeParts(AValue: TDateTimeParts);
994 begin
995   if FHideDateTimeParts <> AValue then begin
996     FHideDateTimeParts := AValue;
997     AdjustEffectiveHideDateTimeParts;
998   end;
999 end;
1000 
1001 procedure TCustomDateTimePicker.SetKind(const AValue: TDateTimeKind);
1002 begin
1003   if FKind <> AValue then begin
1004     FKind := AValue;
1005     AdjustEffectiveHideDateTimeParts;
1006   end;
1007 end;
1008 
1009 procedure TCustomDateTimePicker.SetLeadingZeros(const AValue: Boolean);
1010 begin
1011   if FLeadingZeros = AValue then Exit;
1012 
1013   FLeadingZeros := AValue;
1014   UpdateDate;
1015 end;
1016 
1017 procedure TCustomDateTimePicker.SetMonthNames(AValue: String);
1018 var
1019   I, N, LenMNSep: Integer;
1020   MonthNamesSeparator: String;
1021 
1022 begin
1023   if FMonthNames <> AValue then begin
1024     AValue := TrimRight(AValue);
1025     FMonthNames := AValue;
1026 
1027     if UpperCase(AValue) = 'SHORT' then
1028       for I := Low(TMonthNameArray) to High(TMonthNameArray) do
1029         FMonthNamesArray[I] := AnsiToUtf8(DefaultFormatSettings.ShortMonthNames[I])
1030     else begin
1031       N := 0;
1032       if Length(AValue) >= 24 then begin
1033         MonthNamesSeparator := UTF8Copy(AValue, 1, 1);
1034         LenMNSep := Length(MonthNamesSeparator);
1035         if LenMNSep > 0 then begin
1036           Delete(AValue, 1, LenMNSep);
1037 
1038           while N < 12 do begin
1039             I := Pos(MonthNamesSeparator, AValue);
1040             if I <= 1 then begin
1041               if (I = 0) and (N = 11) and (Length(AValue) > 0) then begin
1042                 Inc(N);
1043                 FMonthNamesArray[N] := AValue;
1044               end;
1045 
1046               Break;
1047             end;
1048 
1049             Inc(N);
1050             Dec(I);
1051             FMonthNamesArray[N] := Copy(AValue, 1, I);
1052             Delete(AValue, 1, I + LenMNSep);
1053           end;
1054 
1055         end;
1056       end;
1057 
1058       if N < 12 then
1059         for I := Low(TMonthNameArray) to High(TMonthNameArray) do
1060           FMonthNamesArray[I] := AnsiToUtf8(DefaultFormatSettings.LongMonthNames[I]);
1061     end;
1062 
1063     if FShowMonthNames and
1064               not (dtpMonth in FEffectiveHideDateTimeParts) then begin
1065       FRecalculatingTextSizesNeeded := True;
1066       UpdateDate;
1067     end;
1068   end;
1069 end;
1070 
1071 procedure TCustomDateTimePicker.SetNullInputAllowed(const AValue: Boolean);
1072 begin
1073   FNullInputAllowed := AValue;
1074 end;
1075 
1076 procedure TCustomDateTimePicker.SetOptions(
1077   const aOptions: TDateTimePickerOptions);
1078 begin
1079   if FOptions = aOptions then Exit;
1080   FOptions := aOptions;
1081 
1082   if FArrowButton<>nil then
1083     FArrowButton.Flat := dtpoFlatButton in Options;
1084 
1085   if FUpDown <> nil then
1086     TDTUpDown(FUpDown).Flat := dtpoFlatButton in Options;
1087 
1088   CheckTextEnabled;
1089   Invalidate;
1090 end;
1091 
1092 procedure TCustomDateTimePicker.SetDate(const AValue: TDate);
1093 begin
1094   if IsNullDate(AValue) then
1095     DateTime := NullDate
1096   else if DateIsNull then
1097     DateTime := Int(AValue)
1098   else
1099     DateTime := ComposeDateTime(AValue, FDateTime);
1100 end;
1101 
1102 procedure TCustomDateTimePicker.SetDateTime(const AValue: TDateTime);
1103 begin
1104   if not EqualDateTime(AValue, FDateTime) then begin
1105     if IsNullDate(AValue) then
1106       FDateTime := NullDate
1107     else
1108       FDateTime := AValue;
1109 
1110     UpdateDate(dtpoDoChangeOnSetDateTime in FOptions);
1111   end else
1112     UpdateDate;
1113 
1114 end;
1115 
1116 procedure TCustomDateTimePicker.SetDateSeparator(const AValue: String);
1117 begin
1118   SetSeparators(AValue, FTimeSeparator);
1119 end;
1120 
1121 procedure TCustomDateTimePicker.SetMaxDate(const AValue: TDate);
1122 begin
1123   if not IsNullDate(AValue) then begin
1124 
1125     if AValue > TheBiggestDate then
1126       FMaxDate := TheBiggestDate
1127     else if AValue <= FMinDate then
1128       FMaxDate := FMinDate
1129     else
1130       FMaxDate := Int(AValue);
1131 
1132     if not DateIsNull then
1133       if FMaxDate < GetDate then
1134         SetDate(FMaxDate);
1135 
1136     AdjustEffectiveCenturyFrom;
1137   end;
1138 end;
1139 
1140 procedure TCustomDateTimePicker.SetMinDate(const AValue: TDate);
1141 begin
1142   if not IsNullDate(AValue) then begin
1143 
1144     if AValue < TheSmallestDate then
1145       FMinDate := TheSmallestDate
1146     else if AValue >= FMaxDate then
1147       FMinDate := FMaxDate
1148     else
1149       FMinDate := Int(AValue);
1150 
1151     if not DateIsNull then
1152       if FMinDate > GetDate then
1153         SetDate(FMinDate);
1154 
1155     AdjustEffectiveCenturyFrom;
1156   end;
1157 end;
1158 
1159 procedure TCustomDateTimePicker.SetReadOnly(const AValue: Boolean);
1160 begin
1161   if FReadOnly <> AValue then begin
1162     if AValue then
1163       ConfirmChanges;
1164 
1165     FReadOnly := AValue;
1166   end;
1167 end;
1168 
1169 procedure TCustomDateTimePicker.SetShowCheckBox(const AValue: Boolean);
1170 begin
1171   if FShowCheckBox = AValue then
1172     Exit;
1173 
1174   FShowCheckBox := AValue;
1175   ArrangeCtrls;
1176 end;
1177 
1178 procedure TCustomDateTimePicker.SetShowMonthNames(AValue: Boolean);
1179 begin
1180   if FShowMonthNames <> AValue then begin
1181     FShowMonthNames := AValue;
1182     if not (dtpMonth in FEffectiveHideDateTimeParts) then begin
1183       FRecalculatingTextSizesNeeded := True;
1184       UpdateDate;
1185     end;
1186   end;
1187 end;
1188 
1189 procedure TCustomDateTimePicker.SetTextForNullDate(const AValue: TCaption);
1190 begin
1191   if FTextForNullDate = AValue then
1192     Exit;
1193 
1194   FTextForNullDate := AValue;
1195   if DateIsNull then
1196     Invalidate;
1197 end;
1198 
1199 procedure TCustomDateTimePicker.SetTime(const AValue: TTime);
1200 begin
1201   if IsNullDate(AValue) then
1202     DateTime := NullDate
1203   else if DateIsNull then
1204     DateTime := ComposeDateTime(Max(Min(SysUtils.Date, MaxDate), MinDate), AValue)
1205   else
1206     DateTime := ComposeDateTime(FDateTime, AValue);
1207 end;
1208 
1209 procedure TCustomDateTimePicker.SetTimeSeparator(const AValue: String);
1210 begin
1211   SetSeparators(FDateSeparator, AValue);
1212 end;
1213 
1214 procedure TCustomDateTimePicker.SetTimeDisplay(const AValue: TTimeDisplay);
1215 begin
1216   if FTimeDisplay <> AValue then begin
1217     FTimeDisplay:=AValue;
1218     AdjustEffectiveHideDateTimeParts;
1219   end;
1220 end;
1221 
1222 procedure TCustomDateTimePicker.SetTimeFormat(const AValue: TTimeFormat);
1223 begin
1224   if FTimeFormat <> AValue then begin
1225     FTimeFormat := AValue;
1226     AdjustEffectiveHideDateTimeParts;
1227   end;
1228 end;
1229 
1230 procedure TCustomDateTimePicker.SetTrailingSeparator(const AValue: Boolean);
1231 begin
1232   if FTrailingSeparator <> AValue then begin
1233     FTrailingSeparator := AValue;
1234     FRecalculatingTextSizesNeeded := True;
1235     UpdateIfUserChangedText;
1236     Invalidate;
1237   end;
1238 end;
1239 
1240 procedure TCustomDateTimePicker.SetUseDefaultSeparators(const AValue: Boolean);
1241 begin
1242   if FUseDefaultSeparators <> AValue then begin
1243     if AValue then begin
1244       SetSeparators(DefaultFormatSettings.DateSeparator,
1245                       DefaultFormatSettings.TimeSeparator);
1246         // Note that here, in SetSeparators procedure,
1247         // the field FUseDefaultSeparators is set to False.
1248     end;
1249     // Therefore, the following line must NOT be moved above.
1250     FUseDefaultSeparators := AValue;
1251   end;
1252 end;
1253 
GetHournull1254 function TCustomDateTimePicker.GetHour: Word;
1255 begin
1256   Result := GetHMSMs.Hour;
1257 end;
1258 
GetMiliSecnull1259 function TCustomDateTimePicker.GetMiliSec: Word;
1260 begin
1261   Result := GetHMSMs.MiliSec;
1262 end;
1263 
TCustomDateTimePicker.GetMinutenull1264 function TCustomDateTimePicker.GetMinute: Word;
1265 begin
1266   Result := GetHMSMs.Minute;
1267 end;
1268 
TCustomDateTimePicker.GetSecondnull1269 function TCustomDateTimePicker.GetSecond: Word;
1270 begin
1271   Result := GetHMSMs.Second;
1272 end;
1273 
1274 { RecalculateTextSizesIfNeeded
1275  --------------------------------
1276   In this procedure we measure text and store the values in the following
1277   fields: FDateWidth, FTimeWidth, FTextWidth, FTextHeigth, FDigitWidth,
1278   FSeparatorWidth, FTimeSeparatorWidth, FSepNoSpaceWidth. These fields are used
1279   in calculating our preffered size and when painting.
1280   The procedure is called internally when needed (when properties which
1281   influence the appearence change). }
1282 procedure TCustomDateTimePicker.RecalculateTextSizesIfNeeded;
1283 const
1284   NullMonthChar = 'x';
1285 var
1286   C: Char;
1287   N, J: Integer;
1288   S: String;
1289   I: TDateTimePart;
1290   DateParts, TimeParts: Integer;
1291 begin
1292   if HandleAllocated and FRecalculatingTextSizesNeeded then begin
1293     FRecalculatingTextSizesNeeded := False;
1294 
1295     FDigitWidth := 0;
1296     for C := '0' to '9' do begin
1297       N := Canvas.GetTextWidth(C);
1298       if N > FDigitWidth then
1299         FDigitWidth := N;
1300     end;
1301 
1302     DateParts := 0;
1303     FSepNoSpaceWidth := 0;
1304     FSeparatorWidth := 0;
1305     FMonthWidth := 0;
1306     FDateWidth := 0;
1307     FNullMonthText := '';
1308     S := '';
1309     if FKind in [dtkDate, dtkDateTime] then begin
1310 
1311       for I := dtpDay to dtpYear do
1312         if not (I in FEffectiveHideDateTimeParts) then begin
1313           Inc(DateParts);
1314           if I = dtpYear then begin
1315             FDateWidth := FDateWidth + 4 * FDigitWidth;
1316           end else if (I = dtpMonth) and FShowMonthNames then begin
1317             FMonthWidth := FDigitWidth; // Minimal MonthWidth is DigitWidth.
1318             for J := Low(TMonthNameArray) to High(TMonthNameArray) do begin
1319               N := Canvas.GetTextWidth(FMonthNamesArray[J]);
1320               if N > FMonthWidth then
1321                 FMonthWidth := N;
1322             end;
1323 
1324             N := Canvas.GetTextWidth(NullMonthChar);
1325             if N > 0 then begin
1326               N := FMonthWidth div N - 1;
1327               if N > 1 then
1328                 FNullMonthText := StringOfChar(NullMonthChar, N);
1329             end;
1330             if N <= 1 then
1331               FNullMonthText := NullMonthChar;
1332 
1333             FDateWidth := FDateWidth + FMonthWidth;
1334           end else
1335             FDateWidth := FDateWidth + 2 * FDigitWidth;
1336 
1337         end;
1338 
1339       if DateParts > 0 then begin
1340         if FTrailingSeparator then begin
1341           FSepNoSpaceWidth := Canvas.GetTextWidth(TrimRight(FDateSeparator));
1342           Inc(FDateWidth, FSepNoSpaceWidth);
1343         end;
1344 
1345         if DateParts > 1 then begin
1346           FSeparatorWidth := Canvas.GetTextWidth(FDateSeparator);
1347           S := FDateSeparator;
1348 
1349           FDateWidth := FDateWidth + (DateParts - 1) * FSeparatorWidth;
1350         end;
1351       end;
1352 
1353     end;
1354 
1355     TimeParts := 0;
1356     FTimeWidth := 0;
1357     FAMPMWidth := 0;
1358     FTimeSeparatorWidth := 0;
1359     if FKind in [dtkTime, dtkDateTime] then begin
1360 
1361       for I := dtpHour to dtpMiliSec do
1362         if not (I in FEffectiveHideDateTimeParts) then begin
1363           Inc(TimeParts);
1364 
1365           if I = dtpMiliSec then
1366             FTimeWidth := FTimeWidth + 3 * FDigitWidth
1367           else
1368             FTimeWidth := FTimeWidth + 2 * FDigitWidth;
1369 
1370         end;
1371 
1372       if TimeParts > 1 then begin
1373         FTimeSeparatorWidth := Canvas.GetTextWidth(FTimeSeparator);
1374         S := S + FTimeSeparator;
1375         FTimeWidth := FTimeWidth + (TimeParts - 1) * FTimeSeparatorWidth;
1376       end;
1377 
1378       if not (dtpAMPM in FEffectiveHideDateTimeParts) then begin
1379         S := S + 'APM';
1380         FAMPMWidth := Max(Canvas.TextWidth('AM'), Canvas.TextWidth('PM'));
1381         FTimeWidth := FTimeWidth + FDigitWidth + FAMPMWidth;
1382       end;
1383 
1384     end;
1385 
1386     FTextWidth := FDateWidth + FTimeWidth;
1387     if (DateParts > 0) and (TimeParts > 0) then
1388       FTextWidth := FTextWidth + 2 * FDigitWidth;
1389 
1390     FTextHeight := Canvas.GetTextHeight('0123456789' + S);
1391 
1392   end;
1393 end;
1394 
TCustomDateTimePicker.GetDaynull1395 function TCustomDateTimePicker.GetDay: Word;
1396 begin
1397   Result := GetYYYYMMDD.Day;
1398 end;
1399 
GetMonthnull1400 function TCustomDateTimePicker.GetMonth: Word;
1401 begin
1402   Result := GetYYYYMMDD.Month;
1403 end;
1404 
GetYearnull1405 function TCustomDateTimePicker.GetYear: Word;
1406 begin
1407   Result := GetYYYYMMDD.Year;
1408 end;
1409 
TCustomDateTimePicker.GetHMSMsnull1410 function TCustomDateTimePicker.GetHMSMs(const NowIfNull: Boolean): THMSMs;
1411 begin
1412   if DateIsNull then begin
1413     if NowIfNull then
1414       DecodeTime(SysUtils.Time, Result.Hour, Result.Minute, Result.Second, Result.MiliSec)
1415     else
1416       with Result do begin
1417         Hour := 0;
1418         Minute := 0;
1419         Second := 0;
1420         MiliSec := 0;
1421       end;
1422   end else
1423     DecodeTime(FDateTime, Result.Hour, Result.Minute, Result.Second, Result.MiliSec);
1424 end;
1425 
GetYYYYMMDDnull1426 function TCustomDateTimePicker.GetYYYYMMDD(const TodayIfNull: Boolean;
1427   const WithCorrection: Boolean): TYMD;
1428 begin
1429   if DateIsNull then begin
1430     if TodayIfNull then
1431       DecodeDate(SysUtils.Date, Result.Year, Result.Month, Result.Day)
1432     else
1433       with Result do begin
1434         Day := 0;
1435         Month := 0;
1436         Year := 0;
1437       end;
1438   end else begin
1439     DecodeDate(FDateTime, Result.Year, Result.Month, Result.Day);
1440     if WithCorrection then begin
1441       case FCorrectedDTP of
1442         dtpDay:
1443           Result.Day := FCorrectedValue;
1444         dtpMonth:
1445           Result.Month := FCorrectedValue;
1446         dtpYear:
1447           Result.Year := FCorrectedValue;
1448       end;
1449     end;
1450   end;
1451 end;
1452 
1453 procedure TCustomDateTimePicker.SetHour(const AValue: Word);
1454 var
1455   HMSMs: THMSMs;
1456 begin
1457   SelectHour;
1458 
1459   HMSMs := GetHMSMs(True);
1460   HMSMs.Hour := AValue;
1461 
1462   SetHMSMs(HMSMs);
1463 end;
1464 
1465 procedure TCustomDateTimePicker.SetMiliSec(const AValue: Word);
1466 var
1467   HMSMs: THMSMs;
1468 begin
1469   SelectMiliSec;
1470 
1471   HMSMs := GetHMSMs(True);
1472   HMSMs.MiliSec := AValue;
1473 
1474   SetHMSMs(HMSMs);
1475 end;
1476 
1477 procedure TCustomDateTimePicker.SetMinute(const AValue: Word);
1478 var
1479   HMSMs: THMSMs;
1480 begin
1481   SelectMinute;
1482 
1483   HMSMs := GetHMSMs(True);
1484   HMSMs.Minute := AValue;
1485 
1486   SetHMSMs(HMSMs);
1487 end;
1488 
1489 procedure TCustomDateTimePicker.SetSecond(const AValue: Word);
1490 var
1491   HMSMs: THMSMs;
1492 begin
1493   SelectSecond;
1494 
1495   HMSMs := GetHMSMs(True);
1496   HMSMs.Second := AValue;
1497 
1498   SetHMSMs(HMSMs);
1499 end;
1500 
1501 procedure TCustomDateTimePicker.SetSeparators(const DateSep, TimeSep: String);
1502 var
1503   SeparatorsChanged: Boolean;
1504 begin
1505   FUseDefaultSeparators := False;
1506   SeparatorsChanged := False;
1507 
1508   if FDateSeparator <> DateSep then begin
1509     FDateSeparator := DateSep;
1510     SeparatorsChanged := True;
1511   end;
1512 
1513   if FTimeSeparator <> TimeSep then begin
1514     FTimeSeparator := TimeSep;
1515     SeparatorsChanged := True;
1516   end;
1517 
1518   if SeparatorsChanged then begin
1519     FRecalculatingTextSizesNeeded := True;
1520     Invalidate;
1521   end;
1522 
1523 end;
1524 
1525 procedure TCustomDateTimePicker.SetDay(const AValue: Word);
1526 var
1527   YMD: TYMD;
1528 begin
1529   SelectDay;
1530   YMD := GetYYYYMMDD(True, True);
1531 
1532   YMD.Day := AValue;
1533   SetYYYYMMDD(YMD);
1534 end;
1535 
1536 procedure TCustomDateTimePicker.SetMonth(const AValue: Word);
1537 var
1538   YMD: TYMD;
1539   N: Word;
1540 begin
1541   SelectMonth;
1542   YMD := GetYYYYMMDD(True, True);
1543 
1544   YMD.Month := AValue;
1545 
1546   N := NumberOfDaysInMonth(YMD.Month, YMD.Year);
1547   if YMD.Day > N then
1548     YMD.Day := N;
1549 
1550   SetYYYYMMDD(YMD);
1551 end;
1552 
1553 procedure TCustomDateTimePicker.SetYear(const AValue: Word);
1554 var
1555   YMD: TYMD;
1556 begin
1557   SelectYear;
1558 
1559   YMD := GetYYYYMMDD(True, True);
1560   YMD.Year := AValue;
1561   if (YMD.Month = 2) and (YMD.Day > 28) and (not IsLeapYear(YMD.Year)) then
1562     YMD.Day := 28;
1563 
1564   SetYYYYMMDD(YMD);
1565 end;
1566 
1567 procedure TCustomDateTimePicker.SetYYYYMMDD(const AValue: TYMD);
1568 var
1569   D: TDateTime;
1570 begin
1571   if TryEncodeDate(AValue.Year, AValue.Month, AValue.Day, D) then
1572     SetDate(D)
1573   else
1574     UpdateDate;
1575 end;
1576 
1577 procedure TCustomDateTimePicker.SetHMSMs(const AValue: THMSMs);
1578 var
1579   T: TDateTime;
1580 begin
1581   if TryEncodeTime(AValue.Hour, AValue.Minute,
1582                                   AValue.Second, AValue.MiliSec, T) then
1583     SetTime(T)
1584   else
1585     UpdateDate;
1586 end;
1587 
1588 procedure TCustomDateTimePicker.UpdateIfUserChangedText;
1589 var
1590   W: Word;
1591   S: String;
1592 begin
1593   if FUserChangedText then begin
1594     Inc(FUserChanging);
1595     try
1596       FUserChangedText := False;
1597       S := Trim(GetSelectedText);
1598 
1599       if FSelectedTextPart = 8 then begin
1600         W := GetHour;
1601         if upCase(S[1]) = 'A' then begin
1602           if W >= 12 then
1603             Dec(W, 12);
1604         end else begin
1605           if W < 12 then
1606             Inc(W, 12);
1607         end;
1608         SetHour(W);
1609         FSelectedTextPart := 8;
1610       end else begin
1611 
1612         W := StrToInt(S);
1613         case GetSelectedDateTimePart of
1614           dtpYear:
1615             begin
1616               if Length(S) <= 2 then begin
1617                 // If user entered the year in two digit format (or even only
1618                 // one digit), we will set the year according to the CenturyFrom
1619                 // property (We actually use FEffectiveCenturyFrom field, which
1620                 // is adjusted to take care of MinDate and MaxDate properties,
1621                 // besides CenturyFrom).
1622                 if W >= (FEffectiveCenturyFrom mod 100) then
1623                   W := W + 100 * (FEffectiveCenturyFrom div 100)
1624                 else
1625                   W := W + 100 * (FEffectiveCenturyFrom div 100 + 1);
1626 
1627               end;
1628               SetYear(W);
1629             end;
1630 
1631           dtpDay:
1632             SetDay(W);
1633 
1634           dtpMonth:
1635             SetMonth(W);
1636 
1637           dtpHour:
1638             begin
1639               if (FTimeFormat = tf12) then begin
1640                 if GetHour < 12 then begin
1641                   if W = 12 then
1642                     SetHour(0)
1643                   else
1644                     SetHour(W);
1645                 end else begin
1646                   if W = 12 then
1647                     SetHour(W)
1648                   else
1649                     SetHour(W + 12);
1650                 end;
1651               end else
1652                 SetHour(W);
1653             end;
1654           dtpMinute:
1655             SetMinute(W);
1656           dtpSecond:
1657             SetSecond(W);
1658           dtpMiliSec:
1659             SetMiliSec(W);
1660 
1661         end;
1662 
1663       end;
1664     finally
1665       FCorrectedDTP := dtpAMPM;
1666       Dec(FUserChanging);
1667     end;
1668   end;
1669 end;
1670 
TCustomDateTimePicker.GetSelectedTextnull1671 function TCustomDateTimePicker.GetSelectedText: String;
1672 begin
1673   if FSelectedTextPart <= 3 then
1674     Result := FTextPart[FSelectedTextPart]
1675   else
1676     Result := FTimeText[TDateTimePart(FSelectedTextPart - 1)];
1677 end;
1678 
1679 procedure TCustomDateTimePicker.AdjustSelection;
1680 begin
1681   if GetDateTimePartFromTextPart(FSelectedTextPart) in
1682                    FEffectiveHideDateTimeParts then
1683     MoveSelectionLR(False);
1684 end;
1685 
1686 procedure TCustomDateTimePicker.AdjustEffectiveCenturyFrom;
1687 var
1688   Y1, Y2, M, D: Word;
1689 begin
1690   DecodeDate(FMinDate, Y1, M, D);
1691 
1692   if Y1 > FCenturyFrom then
1693     FEffectiveCenturyFrom := Y1 // If we use CenturyFrom which is set to value
1694          // below MinDate's year, then when user enters two digit year, the
1695          // DateTime would automatically be set to MinDate value, even though
1696          // we perhaps allow same two-digit year in following centuries. It
1697          // would be less user friendly.
1698          // This is therefore better.
1699 
1700   else begin
1701     DecodeDate(FMaxDate, Y2, M, D);
1702 
1703     if Y2 < 100 then
1704       Y2 := 0
1705     else
1706       Dec(Y2, 99); // -- We should not use CenturyFrom if it is set to value
1707        // greater then MaxDate's year minus 100 years.
1708        // For example:
1709        // if CenturyFrom = 1941 and MaxDate = 31.12.2025, then if user enters
1710        // Year 33, we could not set the year to 2033 anyway, because of MaxDate
1711        // limit. Note that if we just leave CenturyFrom to effectively remain as
1712        // is, then in case of our example the DateTime would be automatically
1713        // reduced to MaxDate value. Setting the year to 1933 is rather expected
1714        // behaviour, so our internal field FEffectiveCenturyFrom should be 1926.
1715 
1716     // Therefore:
1717     if Y2 < FCenturyFrom then
1718       FEffectiveCenturyFrom := Max(Y1, Y2)
1719     else
1720       FEffectiveCenturyFrom := FCenturyFrom; // -- FCenturyFrom has passed all
1721                    // our tests, so we'll really use it without any correction.
1722   end;
1723 end;
1724 
1725 { AdjustEffectiveDateDisplayOrder procedure
1726  -------------------------------------------
1727   If date display order ddoTryDefault is set, then we will decide which
1728   display order to use according to ShortDateFormat global variable. This
1729   procedure tries to achieve that by searching through short date format string,
1730   to see which letter comes first -- d, m or y. When it finds any of these
1731   characters, it assumes that date order should be d-m-y, m-d-y, or y-m-d
1732   respectively. If the search through ShortDateFormat is unsuccessful by any
1733   chance, we try the same with LongDateFormat global variable. If we don't
1734   succeed again, we'll assume y-m-d order.  }
1735 procedure TCustomDateTimePicker.AdjustEffectiveDateDisplayOrder;
1736 var
1737   S: String;
1738   I, J, Le: Integer;
1739   InQuoteChar: Char;
1740 begin
1741   if FDateDisplayOrder = ddoTryDefault then begin
1742     S := DefaultFormatSettings.ShortDateFormat;
1743     FEffectiveDateDisplayOrder := ddoTryDefault;
1744 
1745     repeat
1746       InQuoteChar := Chr(0);
1747       Le := Length(S);
1748 
1749       I := 0;
1750       while I < Le do begin
1751         Inc(I);
1752         if InQuoteChar = Chr(0) then begin
1753           case S[I] of
1754             '''', '"':
1755               InQuoteChar := S[I];
1756             'D', 'd':
1757               begin
1758                 { If 3 or more "d"-s are standing together, then it's day
1759                   of week, but here we are interested in day of month.
1760                   So, we have to see what is following:  }
1761                 J := I + 1;
1762                 while (J <= Le) and (upCase(S[J]) = 'D') do
1763                   Inc(J);
1764 
1765                 if J <= I + 2 then begin
1766                   FEffectiveDateDisplayOrder := ddoDMY;
1767                   Break;
1768                 end;
1769 
1770                 I := J - 1;
1771               end;
1772             'M', 'm':
1773               begin
1774                 FEffectiveDateDisplayOrder := ddoMDY;
1775                 Break;
1776               end;
1777             'Y', 'y':
1778               begin
1779                 FEffectiveDateDisplayOrder := ddoYMD;
1780                 Break;
1781               end;
1782           end;
1783         end else
1784           if S[I] = InQuoteChar then
1785             InQuoteChar := Chr(0);
1786 
1787       end;
1788 
1789       if FEffectiveDateDisplayOrder = ddoTryDefault then begin
1790         { We couldn't decide with ShortDateFormat, let's try with
1791           LongDateFormat now. }
1792         S := DefaultFormatSettings.LongDateFormat;
1793         { But now we must set something to be default. This ensures that the
1794           repeat loop breaks next time. If we don't find anything in
1795           LongDateFormat, we'll leave with y-m-d order. }
1796         FEffectiveDateDisplayOrder := ddoYMD;
1797 
1798       end else
1799         Break;
1800 
1801     until False;
1802 
1803   end else
1804     FEffectiveDateDisplayOrder := FDateDisplayOrder;
1805 
1806   case FEffectiveDateDisplayOrder of
1807     ddoDMY:
1808       begin
1809         FDayPos := 1;
1810         FMonthPos := 2;
1811         FYearPos := 3;
1812       end;
1813     ddoMDY:
1814       begin
1815         FDayPos := 2;
1816         FMonthPos := 1;
1817         FYearPos := 3;
1818       end;
1819     ddoYMD:
1820       begin
1821         FDayPos := 3;
1822         FMonthPos := 2;
1823         FYearPos := 1;
1824       end;
1825   end;
1826 
1827 end;
1828 
1829 procedure TCustomDateTimePicker.AdjustEffectiveHideDateTimeParts;
1830 var
1831   I: TDateTimePart;
1832   PreviousEffectiveHideDateTimeParts: set of TDateTimePart;
1833 begin
1834   PreviousEffectiveHideDateTimeParts := FEffectiveHideDateTimeParts;
1835   FEffectiveHideDateTimeParts := [];
1836 
1837   for I := Low(TDateTimeParts) to High(TDateTimeParts) do
1838     if I in FHideDateTimeParts then
1839       Include(FEffectiveHideDateTimeParts, I);
1840 
1841   if FKind = dtkDate then
1842     FEffectiveHideDateTimeParts := FEffectiveHideDateTimeParts +
1843                        [dtpHour, dtpMinute, dtpSecond, dtpMiliSec, dtpAMPM]
1844   else begin
1845     if FKind = dtkTime then
1846       FEffectiveHideDateTimeParts := FEffectiveHideDateTimeParts +
1847                             [dtpDay, dtpMonth, dtpYear];
1848 
1849     case FTimeDisplay of
1850       tdHM:
1851         FEffectiveHideDateTimeParts := FEffectiveHideDateTimeParts +
1852                             [dtpSecond, dtpMiliSec];
1853       tdHMS:
1854         FEffectiveHideDateTimeParts := FEffectiveHideDateTimeParts +
1855                                         [dtpMiliSec];
1856     end;
1857 
1858     if (FTimeFormat = tf24) or (dtpHour in FEffectiveHideDateTimeParts) then
1859       Include(FEffectiveHideDateTimeParts, dtpAMPM);
1860   end;
1861 
1862   if FEffectiveHideDateTimeParts
1863                           <> PreviousEffectiveHideDateTimeParts then begin
1864     AdjustSelection;
1865     FRecalculatingTextSizesNeeded := True;
1866     UpdateShowArrowButton;
1867     UpdateDate;
1868   end;
1869 end;
1870 
1871 procedure TCustomDateTimePicker.SelectDateTimePart(
1872   const DateTimePart: TDateTimePart);
1873 begin
1874   if not (DateTimePart in FEffectiveHideDateTimeParts) then begin
1875     case DateTimePart of
1876       dtpDay:
1877         FSelectedTextPart := FDayPos;
1878       dtpMonth:
1879         FSelectedTextPart := FMonthPos;
1880       dtpYear:
1881         FSelectedTextPart := FYearPos;
1882     else
1883       FSelectedTextPart := 1 + Ord(DateTimePart);
1884     end;
1885 
1886     Invalidate;
1887   end;
1888 end;
1889 
1890 procedure TCustomDateTimePicker.DestroyCalendarForm;
1891 begin
1892   if Assigned(FCalendarForm) then begin
1893     TDTCalendarForm(FCalendarForm).FClosing := True;
1894     FCalendarForm.Release;
1895     FCalendarForm := nil;
1896   end;
1897 end;
1898 
TCustomDateTimePicker.GetControlClassDefaultSizenull1899 class function TCustomDateTimePicker.GetControlClassDefaultSize: TSize;
1900 begin
1901   Result.cx := 102;
1902   Result.cy := 23;
1903 end;
1904 
1905 procedure TCustomDateTimePicker.ConfirmChanges;
1906 begin
1907   UpdateIfUserChangedText;
1908   FConfirmedDateTime := FDateTime;
1909 end;
1910 
1911 procedure TCustomDateTimePicker.UndoChanges;
1912 begin
1913   if FDateTime = FConfirmedDateTime then begin
1914     Inc(FSkipChangeInUpdateDate); // prevents calling Change in UpdateDate,
1915     try  // but UpdateDate should be called anyway, because user might have
1916          // changed text on screen and it should be updated to what it was.
1917       UpdateDate;
1918     finally
1919       Dec(FSkipChangeInUpdateDate);
1920     end;
1921   end else begin
1922     FDateTime := FConfirmedDateTime;
1923     UpdateDate;
1924   end;
1925 
1926 end;
1927 
1928 { GetDateTimePartFromTextPart function
1929  -----------------------------------------------
1930   Returns part of date/time from the position (1-8). }
TCustomDateTimePicker.GetDateTimePartFromTextPartnull1931 function TCustomDateTimePicker.GetDateTimePartFromTextPart(
1932   TextPart: TTextPart): TDateTimePart;
1933 begin
1934   Result := TDateTimePart(TextPart - 1);
1935 
1936   case FEffectiveDateDisplayOrder of
1937     ddoMDY:
1938       if Result = dtpDay then
1939         Result := dtpMonth
1940       else if Result = dtpMonth then
1941         Result := dtpDay;
1942     ddoYMD:
1943       if Result = dtpDay then
1944         Result := dtpYear
1945       else if Result = dtpYear then
1946         Result := dtpDay;
1947   end;
1948 end;
1949 
1950 { GetSelectedDateTimePart function
1951  ---------------------------------
1952   Returns part of date/time which is currently selected. }
GetSelectedDateTimePartnull1953 function TCustomDateTimePicker.GetSelectedDateTimePart: TDateTimePart;
1954 begin
1955   Result := GetDateTimePartFromTextPart(FSelectedTextPart);
1956 end;
1957 
1958 procedure TCustomDateTimePicker.FontChanged(Sender: TObject);
1959 begin
1960   FRecalculatingTextSizesNeeded := True;
1961   inherited FontChanged(Sender);
1962 end;
1963 
TCustomDateTimePicker.GetCheckBoxRectnull1964 function TCustomDateTimePicker.GetCheckBoxRect(
1965   IgnoreRightToLeft: Boolean): TRect;
1966 var
1967   Details: TThemedElementDetails;
1968   CSize: TSize;
1969 begin
1970   Details := ThemeServices.GetElementDetails(tbCheckBoxCheckedNormal);
1971   CSize := ThemeServices.GetDetailSize(Details);
1972   CSize.cx := ScaleScreenToFont(CSize.cx);
1973   CSize.cy := ScaleScreenToFont(CSize.cy);
1974   if IsRightToLeft and not IgnoreRightToLeft then
1975   begin
1976     Result.Right := ClientWidth-(BorderSpacing.InnerBorder+BorderWidth);
1977     Result.Left := Result.Right-CSize.cx;
1978   end else
1979   begin
1980     Result.Left := BorderSpacing.InnerBorder+BorderWidth;
1981     Result.Right := Result.Left+CSize.cx;
1982   end;
1983   Result.Top := (ClientHeight-CSize.cy) div 2;
1984   Result.Bottom := Result.Top+CSize.cy;
1985 end;
1986 
1987 { GetTextOrigin
1988  ---------------
1989   Returns upper left corner of the rectangle where the text is written.
1990   Also used in calculating our preffered size. }
GetTextOriginnull1991 function TCustomDateTimePicker.GetTextOrigin(IgnoreRightToLeft: Boolean
1992   ): TPoint;
1993 var
1994   R: TRect;
1995 begin
1996   Result.y := BorderSpacing.InnerBorder + BorderWidth;
1997   if FShowCheckBox then
1998   begin
1999     R := GetCheckBoxRect(IgnoreRightToLeft);
2000     if not IgnoreRightToLeft and IsRightToLeft then
2001       Result.x := R.Left - Scale96ToFont(cCheckBoxBorder) - FTextWidth
2002     else
2003       Result.x := R.Right + Scale96ToFont(cCheckBoxBorder);
2004   end else
2005   begin
2006     Result.x := Result.y;
2007     if not IgnoreRightToLeft and IsRightToLeft then
2008       Result.x := ClientWidth - Result.x - FTextWidth;
2009   end;
2010 end;
2011 
2012 { MoveSelectionLR
2013  -----------------
2014   Moves selection to left or to right. If parameter ToLeft is true, then the
2015   selection moves to left, otherwise to right. }
2016 procedure TCustomDateTimePicker.MoveSelectionLR(const ToLeft: Boolean);
2017 var
2018   I, SafetyTextPart: TTextPart;
2019 begin
2020   UpdateIfUserChangedText;
2021 
2022   SafetyTextPart := Low(TTextPart);
2023   I := FSelectedTextPart;
2024   repeat
2025     if ToLeft then begin
2026       if I <= Low(TTextPart) then
2027         I := High(TTextPart)
2028       else
2029         Dec(I);
2030     end else begin
2031       if I >= High(TTextPart) then
2032         I := Low(TTextPart)
2033       else
2034         Inc(I);
2035     end;
2036 
2037     if not (GetDateTimePartFromTextPart(I)
2038                 in FEffectiveHideDateTimeParts) then
2039       FSelectedTextPart := I;
2040 
2041     { Is it possible that all parts are hidden? Yes it is!
2042       So we need to ensure that this doesn't loop forever.
2043       When this insurance text part gets to high value, break }
2044     Inc(SafetyTextPart);
2045   until (I = FSelectedTextPart) or (SafetyTextPart >= High(TTextPart));
2046 end;
2047 
2048 procedure TCustomDateTimePicker.KeyDown(var Key: Word; Shift: TShiftState);
2049 begin
2050   Inc(FUserChanging);
2051   try
2052     if FTextEnabled then
2053       inherited KeyDown(Key, Shift); // calls OnKeyDown event
2054 
2055     CheckAndApplyKeyCode(Key);
2056   finally
2057     Dec(FUserChanging);
2058   end;
2059 
2060 end;
2061 
2062 procedure TCustomDateTimePicker.KeyPress(var Key: char);
2063 begin
2064   if FTextEnabled then begin
2065     Inc(FUserChanging);
2066     try
2067       inherited KeyPress(Key);
2068 
2069       CheckAndApplyKey(Key);
2070     finally
2071       Dec(FUserChanging);
2072     end;
2073 
2074   end;
2075 end;
2076 
2077 { SelectTextPartUnderMouse
2078  --------------------------
2079   This procedure determines which text part (date or time part -- day, month,
2080   year, hour, minute...) should be selected in response to mouse message.
2081   Used in MouseDown and DoMouseWheel methods. }
2082 procedure TCustomDateTimePicker.SelectTextPartUnderMouse(XMouse: Integer);
2083 var
2084   I, M, NX: Integer;
2085   InTime: Boolean;
2086   DTP: TDateTimePart;
2087 begin
2088   UpdateIfUserChangedText;
2089   SetFocusIfPossible;
2090 
2091   if Focused then begin
2092 // Calculating mouse position inside text
2093 //       in order to select date part under mouse cursor.
2094     NX := XMouse - GetTextOrigin.x;
2095 
2096     InTime := False;
2097     if FTimeWidth > 0 then begin
2098       if FDateWidth > 0 then begin
2099         if NX >= FDateWidth + FDigitWidth then begin
2100           InTime := True;
2101           NX := NX - FDateWidth - 2 * FDigitWidth;
2102         end;
2103       end else
2104         InTime := True;
2105     end;
2106 
2107     if InTime then begin
2108       FSelectedTextPart := 8;
2109 
2110       if (dtpAMPM in FEffectiveHideDateTimeParts) or
2111             (NX < FTimeWidth - FAMPMWidth - FDigitWidth div 2) then begin
2112         FSelectedTextPart := 7;
2113         I := 4;
2114         M := FTimeSeparatorWidth div 2;
2115         while I <= 6 do begin
2116           DTP := GetDateTimePartFromTextPart(I);
2117           if not (DTP in FEffectiveHideDateTimeParts) then begin
2118             Inc(M, 2 * FDigitWidth);
2119             if M > NX then begin
2120               FSelectedTextPart := I;
2121               Break;
2122             end;
2123 
2124             Inc(M, FTimeSeparatorWidth);
2125           end;
2126           Inc(I);
2127         end;
2128       end;
2129 
2130     end else if FDateWidth > 0 then begin
2131 
2132       FSelectedTextPart := 3;
2133       I := 1;
2134       M := FSeparatorWidth div 2;
2135       while I <= 2 do begin
2136         if not(GetDateTimePartFromTextPart(I)
2137                       in FEffectiveHideDateTimeParts) then begin
2138           if I = FYearPos then
2139             Inc(M, 4 * FDigitWidth)
2140           else if (I = FMonthPos) and FShowMonthNames then
2141             Inc(M, FMonthWidth)
2142           else
2143             Inc(M, 2 * FDigitWidth);
2144 
2145           if M > NX then begin
2146             FSelectedTextPart := I;
2147             Break;
2148           end;
2149 
2150           Inc(M, FSeparatorWidth);
2151         end;
2152 
2153         Inc(I);
2154       end;
2155 
2156     end;
2157 
2158     if GetDateTimePartFromTextPart(FSelectedTextPart)
2159                     in FEffectiveHideDateTimeParts then
2160       MoveSelectionLR(True);
2161 
2162     Invalidate;
2163 //-------------------------------------------------------
2164   end;
2165 end;
2166 
2167 procedure TCustomDateTimePicker.MouseDown(Button: TMouseButton;
2168   Shift: TShiftState; X, Y: Integer);
2169 var
2170   R: TRect;
2171 begin
2172   if FTextEnabled then
2173     SelectTextPartUnderMouse(X);
2174   if ShowCheckBox then
2175   begin
2176     R := GetCheckBoxRect;
2177     if PtInRect(R, Point(X, Y)) then
2178     begin
2179       Checked := not Checked;
2180     end;
2181   end;
2182   SetFocusIfPossible;
2183   inherited MouseDown(Button, Shift, X, Y);
2184 end;
2185 
2186 procedure TCustomDateTimePicker.MouseLeave;
2187 begin
2188   inherited MouseLeave;
2189   if FShowCheckBox and FMouseInCheckBox then
2190   begin
2191     FMouseInCheckBox := False;
2192     Invalidate;
2193   end;
2194 end;
2195 
2196 procedure TCustomDateTimePicker.MouseMove(Shift: TShiftState; X, Y: Integer);
2197 var
2198   NewMouseInCheckBox: Boolean;
2199 begin
2200   inherited MouseMove(Shift, X, Y);
2201 
2202   if ShowCheckBox then
2203   begin
2204     NewMouseInCheckBox := PtInRect(GetCheckBoxRect, Point(X, Y));
2205     if FMouseInCheckBox<>NewMouseInCheckBox then
2206     begin
2207       FMouseInCheckBox := NewMouseInCheckBox;
2208       Invalidate;
2209     end;
2210   end;
2211 end;
2212 
TCustomDateTimePicker.DoMouseWheelnull2213 function TCustomDateTimePicker.DoMouseWheel(Shift: TShiftState;
2214   WheelDelta: Integer; MousePos: TPoint): Boolean;
2215 begin
2216   Result := False;
2217   if FTextEnabled then begin
2218     SelectTextPartUnderMouse(MousePos.x);
2219     if not FReadOnly then begin
2220       Inc(FUserChanging);
2221       try
2222         if WheelDelta < 0 then
2223           DecreaseCurrentTextPart
2224         else
2225           IncreaseCurrentTextPart;
2226 
2227         Result := True;
2228       finally
2229         Dec(FUserChanging);
2230       end;
2231     end;
2232   end;
2233 end;
2234 
2235 procedure TCustomDateTimePicker.CalculatePreferredSize(var PreferredWidth,
2236   PreferredHeight: integer; WithThemeSpace: Boolean);
2237 var
2238   TextOrigin: TPoint;
2239   M: Integer;
2240 
2241 begin
2242   RecalculateTextSizesIfNeeded;
2243   TextOrigin := GetTextOrigin(True);
2244 
2245   // We must use TextOrigin's x + y (x is, of course, left margin, but not right
2246   // margin if check box is shown. However, y, which is top margin, always
2247   // equals right margin).
2248   PreferredWidth := TextOrigin.x + TextOrigin.y;
2249 
2250   if Assigned(FUpDown) then
2251     Inc(PreferredWidth, FUpDown.Width)
2252   else if Assigned(FArrowButton) then
2253     Inc(PreferredWidth, FArrowButton.Width);
2254 
2255   PreferredWidth := PreferredWidth + FTextWidth;
2256 
2257   M := Width - ClientWidth;
2258   PreferredWidth := PreferredWidth + M;
2259 
2260   PreferredHeight := 2 * TextOrigin.y + FTextHeight + M;
2261 end;
2262 
2263 procedure TCustomDateTimePicker.SetBiDiMode(AValue: TBiDiMode);
2264 begin
2265   inherited SetBiDiMode(AValue);
2266   ArrangeCtrls;
2267 end;
2268 
2269 procedure TCustomDateTimePicker.IncreaseCurrentTextPart;
2270 begin
2271   if DateIsNull then begin
2272     if FSelectedTextPart <= 3 then
2273       SetDateTime(SysUtils.Date)
2274     else
2275       SetDateTime(SysUtils.Now);
2276 
2277   end else begin
2278     case GetSelectedDateTimePart of
2279       dtpDay: IncreaseDay;
2280       dtpMonth: IncreaseMonth;
2281       dtpYear: IncreaseYear;
2282       dtpHour: IncreaseHour;
2283       dtpMinute: IncreaseMinute;
2284       dtpSecond: IncreaseSecond;
2285       dtpMiliSec: IncreaseMiliSec;
2286       dtpAMPM: ChangeAMPM;
2287     end;
2288   end;
2289 end;
2290 
2291 procedure TCustomDateTimePicker.DecreaseCurrentTextPart;
2292 begin
2293   if DateIsNull then begin
2294     if FSelectedTextPart <= 3 then
2295       SetDateTime(SysUtils.Date)
2296     else
2297       SetDateTime(SysUtils.Now);
2298 
2299   end else begin
2300     case GetSelectedDateTimePart of
2301       dtpDay: DecreaseDay;
2302       dtpMonth: DecreaseMonth;
2303       dtpYear: DecreaseYear;
2304       dtpHour: DecreaseHour;
2305       dtpMinute: DecreaseMinute;
2306       dtpSecond: DecreaseSecond;
2307       dtpMiliSec: DecreaseMiliSec;
2308       dtpAMPM: ChangeAMPM;
2309     end;
2310   end;
2311 end;
2312 
2313 procedure TCustomDateTimePicker.IncreaseMonth;
2314 var
2315   YMD: TYMD;
2316   N: Word;
2317 begin
2318   SelectMonth;
2319   if Cascade then
2320     SetDateTime(IncMonth(DateTime))
2321   else begin
2322     YMD := GetYYYYMMDD(True);
2323 
2324     if YMD.Month >= 12 then
2325       YMD.Month := 1
2326     else
2327       Inc(YMD.Month);
2328 
2329     N := NumberOfDaysInMonth(YMD.Month, YMD.Year);
2330     if YMD.Day > N then
2331       YMD.Day := N;
2332 
2333     SetYYYYMMDD(YMD);
2334   end;
2335 end;
2336 
2337 procedure TCustomDateTimePicker.IncreaseYear;
2338 var
2339   YMD: TYMD;
2340 begin
2341   SelectYear;
2342   YMD := GetYYYYMMDD(True);
2343 
2344   Inc(YMD.Year);
2345   if (YMD.Month = 2) and (YMD.Day > 28) and (not IsLeapYear(YMD.Year)) then
2346     YMD.Day := 28;
2347 
2348   SetYYYYMMDD(YMD);
2349 end;
2350 
2351 procedure TCustomDateTimePicker.IncreaseDay;
2352 var
2353   YMD: TYMD;
2354 begin
2355   SelectDay;
2356   if Cascade then
2357     SetDateTime(IncDay(DateTime))
2358   else begin
2359     YMD := GetYYYYMMDD(True);
2360 
2361     if YMD.Day >= NumberOfDaysInMonth(YMD.Month, YMD.Year) then
2362       YMD.Day := 1
2363     else
2364       Inc(YMD.Day);
2365 
2366     SetYYYYMMDD(YMD);
2367   end;
2368 end;
2369 
2370 procedure TCustomDateTimePicker.DecreaseMonth;
2371 var
2372   YMD: TYMD;
2373   N: Word;
2374 begin
2375   SelectMonth;
2376   if Cascade then
2377     SetDateTime(IncMonth(DateTime, -1))
2378   else begin
2379     YMD := GetYYYYMMDD(True);
2380 
2381     if YMD.Month <= 1 then
2382       YMD.Month := 12
2383     else
2384       Dec(YMD.Month);
2385 
2386     N := NumberOfDaysInMonth(YMD.Month, YMD.Year);
2387     if YMD.Day > N then
2388       YMD.Day := N;
2389 
2390     SetYYYYMMDD(YMD);
2391   end;
2392 end;
2393 
2394 procedure TCustomDateTimePicker.DecreaseYear;
2395 var
2396   YMD: TYMD;
2397 begin
2398   SelectYear;
2399   YMD := GetYYYYMMDD(True);
2400   Dec(YMD.Year);
2401   if (YMD.Month = 2) and (YMD.Day > 28) and (not IsLeapYear(YMD.Year)) then
2402     YMD.Day := 28;
2403   SetYYYYMMDD(YMD);
2404 end;
2405 
2406 procedure TCustomDateTimePicker.DecreaseDay;
2407 var
2408   YMD: TYMD;
2409 begin
2410   SelectDay;
2411   if Cascade then
2412     SetDateTime(IncDay(DateTime, -1))
2413   else begin
2414     YMD := GetYYYYMMDD(True);
2415 
2416     if YMD.Day <= 1 then
2417       YMD.Day := NumberOfDaysInMonth(YMD.Month, YMD.Year)
2418     else
2419       Dec(YMD.Day);
2420 
2421     SetYYYYMMDD(YMD);
2422   end;
2423 end;
2424 
2425 procedure TCustomDateTimePicker.IncreaseHour;
2426 var
2427   HMSMs: THMSMs;
2428 begin
2429   SelectHour;
2430   if Cascade then
2431     SetDateTime(IncHour(DateTime))
2432   else begin
2433     HMSMs := GetHMSMs(True);
2434 
2435     if HMSMs.Hour >= 23 then
2436       HMSMs.Hour := 0
2437     else
2438       Inc(HMSMs.Hour);
2439 
2440     SetHMSMs(HMSMs);
2441   end;
2442 end;
2443 
2444 procedure TCustomDateTimePicker.IncreaseMinute;
2445 var
2446   HMSMs: THMSMs;
2447 begin
2448   SelectMinute;
2449   if Cascade then
2450     SetDateTime(IncMinute(DateTime))
2451   else begin
2452     HMSMs := GetHMSMs(True);
2453 
2454     if HMSMs.Minute >= 59 then
2455       HMSMs.Minute := 0
2456     else
2457       Inc(HMSMs.Minute);
2458 
2459     SetHMSMs(HMSMs);
2460   end;
2461 end;
2462 
2463 procedure TCustomDateTimePicker.IncreaseSecond;
2464 var
2465   HMSMs: THMSMs;
2466 begin
2467   SelectSecond;
2468   if Cascade then
2469     SetDateTime(IncSecond(DateTime))
2470   else begin
2471     HMSMs := GetHMSMs(True);
2472 
2473     if HMSMs.Second >= 59 then
2474       HMSMs.Second := 0
2475     else
2476       Inc(HMSMs.Second);
2477 
2478     SetHMSMs(HMSMs);
2479   end;
2480 end;
2481 
2482 procedure TCustomDateTimePicker.IncreaseMiliSec;
2483 var
2484   HMSMs: THMSMs;
2485 begin
2486   SelectMiliSec;
2487   if Cascade then
2488     SetDateTime(IncMilliSecond(DateTime))
2489   else begin
2490     HMSMs := GetHMSMs(True);
2491 
2492     if HMSMs.MiliSec >= 999 then
2493       HMSMs.MiliSec := 0
2494     else
2495       Inc(HMSMs.MiliSec);
2496 
2497     SetHMSMs(HMSMs);
2498   end;
2499 end;
2500 
2501 procedure TCustomDateTimePicker.DecreaseHour;
2502 var
2503   HMSMs: THMSMs;
2504 begin
2505   SelectHour;
2506   if Cascade then
2507     SetDateTime(IncHour(DateTime, -1))
2508   else begin
2509     HMSMs := GetHMSMs(True);
2510 
2511     if HMSMs.Hour <= 0 then
2512       HMSMS.Hour := 23
2513     else
2514       Dec(HMSMs.Hour);
2515 
2516     SetHMSMs(HMSMs);
2517   end;
2518 end;
2519 
2520 procedure TCustomDateTimePicker.DecreaseMinute;
2521 var
2522   HMSMs: THMSMs;
2523 begin
2524   SelectMinute;
2525   if Cascade then
2526     SetDateTime(IncMinute(DateTime, -1))
2527   else begin
2528     HMSMs := GetHMSMs(True);
2529 
2530     if HMSMs.Minute <= 0 then
2531       HMSMs.Minute := 59
2532     else
2533       Dec(HMSMs.Minute);
2534 
2535     SetHMSMs(HMSMs);
2536   end;
2537 end;
2538 
2539 procedure TCustomDateTimePicker.DecreaseSecond;
2540 var
2541   HMSMs: THMSMs;
2542 begin
2543   SelectSecond;
2544   if Cascade then
2545     SetDateTime(IncSecond(DateTime, -1))
2546   else begin
2547     HMSMs := GetHMSMs(True);
2548 
2549     if HMSMs.Second <= 0 then
2550       HMSMs.Second := 59
2551     else
2552       Dec(HMSMs.Second);
2553 
2554     SetHMSMs(HMSMs);
2555   end;
2556 end;
2557 
2558 procedure TCustomDateTimePicker.DecreaseMiliSec;
2559 var
2560   HMSMs: THMSMs;
2561 begin
2562   SelectMiliSec;
2563   if Cascade then
2564     SetDateTime(IncMilliSecond(DateTime, -1))
2565   else begin
2566     HMSMs := GetHMSMs(True);
2567 
2568     if HMSMs.MiliSec <= 0 then
2569       HMSMs.MiliSec := 999
2570     else
2571       Dec(HMSMs.MiliSec);
2572 
2573     SetHMSMs(HMSMs);
2574   end;
2575 end;
2576 
2577 procedure TCustomDateTimePicker.ChangeAMPM;
2578 var
2579   HMSMs: THMSMs;
2580 begin
2581   SelectAMPM;
2582   HMSMs := GetHMSMs(True);
2583 
2584   if HMSMs.Hour >= 12 then
2585     Dec(HMSMS.Hour, 12)
2586   else
2587     Inc(HMSMS.Hour, 12);
2588 
2589   SetHMSMs(HMSMs);
2590 end;
2591 
2592 procedure TCustomDateTimePicker.UpdateDate(const CallChangeFromSetDateTime: Boolean);
2593 var
2594   W: Array[1..3] of Word;
2595   WT: Array[dtpHour..dtpAMPM] of Word;
2596   DTP: TDateTimePart;
2597 begin
2598   FCorrectedDTP := dtpAMPM;
2599 
2600   FUserChangedText := False;
2601 
2602   if not (DateIsNull or FJumpMinMax) then begin
2603     if Int(FDateTime) > FMaxDate then
2604       FDateTime := ComposeDateTime(FMaxDate, FDateTime);
2605 
2606     if FDateTime < FMinDate then
2607       FDateTime := ComposeDateTime(FMinDate, FDateTime);
2608   end;
2609 
2610   if (FSkipChangeInUpdateDate = 0) then begin
2611    // we'll skip the next part if called from UndoChanges
2612    // and in recursive calls which could be made through calling Change
2613     Inc(FSkipChangeInUpdateDate);
2614     try
2615       if (FUserChanging > 0) // the change is caused by user interaction
2616           or CallChangeFromSetDateTime // call from SetDateTime with option dtpoDoChangeOnSetDateTime
2617       then
2618         try
2619           Change;
2620         except
2621           UndoChanges;
2622           raise;
2623         end;
2624 
2625       if FUserChanging = 0 then
2626         FConfirmedDateTime := FDateTime;
2627 
2628     finally
2629       Dec(FSkipChangeInUpdateDate);
2630     end;
2631   end;
2632 
2633   if DateIsNull then begin
2634     if dtpYear in FEffectiveHideDateTimeParts then
2635       FTextPart[FYearPos] := ''
2636     else
2637       FTextPart[FYearPos] := '0000';
2638 
2639     if dtpMonth in FEffectiveHideDateTimeParts then
2640       FTextPart[FMonthPos] := ''
2641     else
2642       FTextPart[FMonthPos] := '00';
2643 
2644     if dtpDay in FEffectiveHideDateTimeParts then
2645       FTextPart[FDayPos] := ''
2646     else
2647       FTextPart[FDayPos] := '00';
2648 
2649     for DTP := dtpHour to dtpAMPM do begin
2650       if DTP in FEffectiveHideDateTimeParts then
2651         FTimeText[DTP] := ''
2652       else if DTP = dtpAMPM then
2653         FTimeText[DTP] := 'XX'
2654       else if DTP = dtpMiliSec then
2655         FTimeText[DTP] := '999'
2656       else
2657         FTimeText[DTP] := '99';
2658     end;
2659 
2660   end else begin
2661     DecodeDate(FDateTime, W[3], W[2], W[1]);
2662 
2663     if dtpYear in FEffectiveHideDateTimeParts then
2664       FTextPart[FYearPos] := ''
2665     else if FLeadingZeros then
2666       FTextPart[FYearPos] := RightStr('000' + IntToStr(W[3]), 4)
2667     else
2668       FTextPart[FYearPos] := IntToStr(W[3]);
2669 
2670     if dtpMonth in FEffectiveHideDateTimeParts then
2671       FTextPart[FMonthPos] := ''
2672     else if FShowMonthNames then
2673       FTextPart[FMonthPos] := FMonthNamesArray[W[2]]
2674     else if FLeadingZeros then
2675       FTextPart[FMonthPos] := RightStr('0' + IntToStr(W[2]), 2)
2676     else
2677       FTextPart[FMonthPos] := IntToStr(W[2]);
2678 
2679     if dtpDay in FEffectiveHideDateTimeParts then
2680       FTextPart[FDayPos] := ''
2681     else if FLeadingZeros then
2682       FTextPart[FDayPos] := RightStr('0' + IntToStr(W[1]), 2)
2683     else
2684       FTextPart[FDayPos] := IntToStr(W[1]);
2685 
2686     DecodeTime(FDateTime, WT[dtpHour], WT[dtpMinute], WT[dtpSecond], WT[dtpMiliSec]);
2687 
2688     if dtpAMPM in FEffectiveHideDateTimeParts then
2689       FTimeText[dtpAMPM] := ''
2690     else begin
2691       if WT[dtpHour] < 12 then begin
2692         FTimeText[dtpAMPM] := 'AM';
2693         if WT[dtpHour] = 0 then
2694           WT[dtpHour] := 12;
2695       end else begin
2696         FTimeText[dtpAMPM] := 'PM';
2697         if WT[dtpHour] > 12 then
2698           Dec(WT[dtpHour], 12);
2699       end;
2700     end;
2701 
2702     for DTP := dtpHour to dtpMiliSec do begin
2703       if DTP in FEffectiveHideDateTimeParts then
2704         FTimeText[DTP] := ''
2705       else if (DTP = dtpHour) and (not FLeadingZeros) then
2706         FTimeText[DTP] := IntToStr(WT[dtpHour])
2707       else if DTP = dtpMiliSec then
2708         FTimeText[DTP] := RightStr('00' + IntToStr(WT[DTP]), 3)
2709       else
2710         FTimeText[DTP] := RightStr('0' + IntToStr(WT[DTP]), 2);
2711 
2712     end;
2713 
2714   end;
2715 
2716   if HandleAllocated then
2717     Invalidate;
2718 end;
2719 
2720 procedure TCustomDateTimePicker.DoEnter;
2721 begin
2722   inherited DoEnter;
2723   Invalidate;
2724 end;
2725 
2726 procedure TCustomDateTimePicker.DoExit;
2727 begin
2728   inherited DoExit;
2729   Invalidate;
2730 end;
2731 
2732 procedure TCustomDateTimePicker.Click;
2733 begin
2734   if FTextEnabled then
2735     inherited Click;
2736 end;
2737 
2738 procedure TCustomDateTimePicker.DblClick;
2739 begin
2740   if FTextEnabled then
2741     inherited DblClick;
2742 end;
2743 
2744 procedure TCustomDateTimePicker.MouseUp(Button: TMouseButton;
2745   Shift: TShiftState; X, Y: Integer);
2746 begin
2747   if FTextEnabled then
2748     inherited MouseUp(Button, Shift, X, Y);
2749 end;
2750 
2751 procedure TCustomDateTimePicker.KeyUp(var Key: Word; Shift: TShiftState);
2752 begin
2753   if FTextEnabled then
2754     inherited KeyUp(Key, Shift);
2755 end;
2756 
2757 procedure TCustomDateTimePicker.UTF8KeyPress(var UTF8Key: TUTF8Char);
2758 begin
2759   if FTextEnabled then
2760     inherited UTF8KeyPress(UTF8Key);
2761 end;
2762 
2763 procedure TCustomDateTimePicker.SelectDay;
2764 begin
2765   SelectDateTimePart(dtpDay);
2766 end;
2767 
2768 procedure TCustomDateTimePicker.SelectMonth;
2769 begin
2770   SelectDateTimePart(dtpMonth);
2771 end;
2772 
2773 procedure TCustomDateTimePicker.SelectYear;
2774 begin
2775   SelectDateTimePart(dtpYear);
2776 end;
2777 
2778 procedure TCustomDateTimePicker.SendExternalKey(const aKey: Char);
2779 var
2780   K: Word;
2781 begin
2782   if FTextEnabled then begin
2783     if aKey in ['n', 'N'] then begin
2784       K := VK_N;
2785       CheckAndApplyKeyCode(K);
2786     end else
2787       CheckAndApplyKey(aKey);
2788   end;
2789 end;
2790 
2791 procedure TCustomDateTimePicker.SendExternalKeyCode(const Key: Word);
2792 var
2793   Ch: Char;
2794   K: Word;
2795 begin
2796   if Key in [Ord('0')..Ord('9'), Ord('a'), Ord('A'), Ord('p'), Ord('P')] then begin
2797     if FTextEnabled then begin
2798       Ch := Char(Key);
2799       CheckAndApplyKey(Ch);
2800     end;
2801   end else begin
2802     K := Key;
2803     CheckAndApplyKeyCode(K);
2804   end;
2805 
2806 end;
2807 
2808 procedure TCustomDateTimePicker.RemoveAllHandlersOfObject(AnObject: TObject);
2809 begin
2810   inherited RemoveAllHandlersOfObject(AnObject);
2811 
2812   if Assigned(FOnChangeHandlers) then
2813     FOnChangeHandlers.RemoveAllMethodsOfObject(AnObject);
2814 
2815   if Assigned(FOnCheckBoxChangeHandlers) then
2816     FOnCheckBoxChangeHandlers.RemoveAllMethodsOfObject(AnObject);
2817 end;
2818 
2819 procedure TCustomDateTimePicker.SelectHour;
2820 begin
2821   SelectDateTimePart(dtpHour);
2822 end;
2823 
2824 procedure TCustomDateTimePicker.SelectMinute;
2825 begin
2826   SelectDateTimePart(dtpMinute);
2827 end;
2828 
2829 procedure TCustomDateTimePicker.SelectSecond;
2830 begin
2831   SelectDateTimePart(dtpSecond);
2832 end;
2833 
2834 procedure TCustomDateTimePicker.SelectMiliSec;
2835 begin
2836   SelectDateTimePart(dtpMiliSec);
2837 end;
2838 
2839 procedure TCustomDateTimePicker.SelectAMPM;
2840 begin
2841   SelectDateTimePart(dtpAMPM);
2842 end;
2843 
2844 procedure TCustomDateTimePicker.SetEnabled(Value: Boolean);
2845 begin
2846   if GetEnabled <> Value then begin
2847     inherited SetEnabled(Value);
2848     CheckTextEnabled;
2849     Invalidate;
2850   end;
2851 end;
2852 
2853 procedure TCustomDateTimePicker.SetAutoSize(Value: Boolean);
2854 begin
2855   if AutoSize <> Value then begin
2856     if Value then
2857       InvalidatePreferredSize;
2858 
2859     inherited SetAutoSize(Value);
2860   end;
2861 end;
2862 
2863 // I had to override CreateWnd, because in design time on Linux Lazarus crashes
2864 // if we try to do anchoring of child controls in constructor.
2865 // Therefore, I needed to ensure that controls anchoring does not take place
2866 // before CreateWnd has done. So, I moved all anchoring code to a procedure
2867 // ArrangeCtrls and introduced a boolean field FDoNotArrangeControls which
2868 // prevents that code from executing before CreateWnd.
2869 //!!! Later, I simplified the arranging procedure, so maybe it can be done now
2870 //    before window creation is done. It's better to leave this delay system,
2871 //    anyway -- we might change anchoring code again for some reason.
2872 procedure TCustomDateTimePicker.CreateWnd;
2873 begin
2874   inherited CreateWnd;
2875 
2876   if FDoNotArrangeControls then begin { This field is set to True in constructor.
2877     Its purpose is to prevent control anchoring until this point. That's because
2878     on Linux Lazarus crashes when control is dropped on form in designer if
2879     particular anchoring code executes before CreateWnd has done its job. }
2880     FDoNotArrangeControls := False;
2881     ArrangeCtrls;
2882   end;
2883 end;
2884 
2885 procedure TCustomDateTimePicker.SetDateTimeJumpMinMax(const AValue: TDateTime);
2886 begin
2887   FJumpMinMax := True;
2888   try
2889     SetDateTime(AValue);
2890   finally
2891     FJumpMinMax := False;
2892   end;
2893 end;
2894 
2895 procedure TCustomDateTimePicker.ArrangeCtrls;
2896 var
2897   C: TControl;
2898 begin
2899   if not FDoNotArrangeControls then begin //Read the note above CreateWnd procedure.
2900     DisableAlign;
2901     try
2902       if Assigned(FUpDown) then
2903         C := FUpDown
2904       else if Assigned(FArrowButton) then
2905         C := FArrowButton
2906       else
2907         C := nil;
2908 
2909       if Assigned(C) then begin
2910         if IsRightToLeft then
2911           C.Align := alLeft
2912         else
2913           C.Align := alRight;
2914 
2915         C.BringToFront;
2916       end;
2917 
2918       CheckTextEnabled;
2919       InvalidatePreferredSize;
2920       AdjustSize;
2921 
2922       Invalidate;
2923     finally
2924       EnableAlign;
2925     end;
2926   end;
2927 end;
2928 
2929 procedure TCustomDateTimePicker.Change;
2930 begin
2931   if Assigned(FOnChange) then
2932     FOnChange(Self);
2933   if FOnChangeHandlers<>nil then
2934     FOnChangeHandlers.CallNotifyEvents(Self);
2935 end;
2936 
2937 procedure TCustomDateTimePicker.SelectDate;
2938 begin
2939   if (FSelectedTextPart > 3)
2940           or (GetDateTimePartFromTextPart(FSelectedTextPart)
2941                   in FEffectiveHideDateTimeParts) then
2942     FSelectedTextPart := 1;
2943 
2944   if GetDateTimePartFromTextPart(FSelectedTextPart)
2945                   in FEffectiveHideDateTimeParts then
2946     MoveSelectionLR(False);
2947 
2948   Invalidate;
2949 end;
2950 
2951 procedure TCustomDateTimePicker.SelectTime;
2952 begin
2953   if (FSelectedTextPart < 4)
2954           or (GetDateTimePartFromTextPart(FSelectedTextPart)
2955                   in FEffectiveHideDateTimeParts) then
2956     FSelectedTextPart := 4;
2957 
2958   if GetDateTimePartFromTextPart(FSelectedTextPart)
2959                   in FEffectiveHideDateTimeParts then
2960     MoveSelectionLR(False);
2961 
2962   Invalidate;
2963 end;
2964 
2965 procedure TCustomDateTimePicker.Paint;
2966 var
2967   I, M, N, K, L: Integer;
2968   DD: Array[1..8] of Integer;
2969   R: TRect;
2970   SelectStep: 0..8;
2971   TextStyle: TTextStyle;
2972   DTP: TDateTimePart;
2973   S: String;
2974 const
2975   CheckStates: array[Boolean, Boolean, Boolean] of TThemedButton = (
2976     ((tbCheckBoxUncheckedDisabled, tbCheckBoxUncheckedDisabled),
2977      (tbCheckBoxCheckedDisabled, tbCheckBoxCheckedDisabled)),
2978     ((tbCheckBoxUncheckedNormal, tbCheckBoxUncheckedHot),
2979      (tbCheckBoxCheckedNormal, tbCheckBoxCheckedHot)));
2980 begin
2981   if ClientRectNeedsInterfaceUpdate then // In Qt widgetset, this solves the
2982     DoAdjustClientRectChange;           // problem of dispositioned client rect.
2983 
2984   if FRecalculatingTextSizesNeeded then begin
2985     if AutoSize then begin
2986       InvalidatePreferredSize;
2987       AdjustSize;
2988     end;
2989 
2990     RecalculateTextSizesIfNeeded;
2991   end;
2992 
2993   TextStyle := Canvas.TextStyle;
2994 
2995   Canvas.Brush.Style := bsSolid;
2996   Canvas.Brush.Color := Color;
2997   Canvas.FillRect(ClientRect);
2998 
2999   R.TopLeft := GetTextOrigin;
3000 
3001   M := 2 * R.Top + FTextHeight;
3002   M := (ClientHeight - M) div 2;
3003 
3004   Inc(R.Top, M);
3005 
3006   R.Bottom := R.Top + FTextHeight;
3007 
3008   TextStyle.Layout := tlCenter;
3009   TextStyle.Wordbreak := False;
3010   TextStyle.Opaque := False;
3011   TextStyle.RightToLeft := IsRightToLeft;
3012 
3013   if ShowCheckBox then
3014     ThemeServices.DrawElement(Canvas.Handle,
3015       ThemeServices.GetElementDetails(CheckStates[Enabled, Checked, FMouseInCheckBox]),
3016       GetCheckBoxRect);
3017 
3018   if DateIsNull and (FTextForNullDate <> '')
3019                        and (not (FTextEnabled and Focused)) then begin
3020 
3021     if IsRightToLeft then begin
3022       TextStyle.Alignment := taRightJustify;
3023       R.Right := R.Left + FTextWidth;
3024       R.Left := 0;
3025     end else begin
3026       TextStyle.Alignment := taLeftJustify;
3027       R.Right := Width;
3028     end;
3029 
3030     if FTextEnabled then
3031       Canvas.Font.Color := Font.Color
3032     else
3033       Canvas.Font.Color := clGrayText;
3034 
3035     Canvas.TextRect(R, R.Left, R.Top, FTextForNullDate, TextStyle);
3036 
3037   end else begin
3038     TextStyle.Alignment := taRightJustify;
3039 
3040     SelectStep := 0;
3041     if FTextEnabled then begin
3042       Canvas.Font.Color := Font.Color;
3043       if Focused then
3044         SelectStep := FSelectedTextPart;
3045     end else begin
3046       Canvas.Font.Color := clGrayText;
3047     end;
3048 
3049     if dtpYear in FEffectiveHideDateTimeParts then begin
3050       DD[FYearPos] := 0;
3051       M := 4;
3052       L := 0;
3053     end else begin
3054       DD[FYearPos] := 4 * FDigitWidth;
3055       M := FYearPos;
3056       L := FYearPos;
3057     end;
3058 
3059     if dtpMonth in FEffectiveHideDateTimeParts then
3060       DD[FMonthPos] := 0
3061     else begin
3062       if FShowMonthNames then
3063         DD[FMonthPos] := FMonthWidth
3064       else
3065         DD[FMonthPos] := 2 * FDigitWidth;
3066 
3067       if FMonthPos < M then
3068         M := FMonthPos;
3069 
3070       if FMonthPos > L then
3071         L := FMonthPos;
3072 
3073     end;
3074 
3075     if dtpDay in FEffectiveHideDateTimeParts then
3076       DD[FDayPos] := 0
3077     else begin
3078       DD[FDayPos] := 2 * FDigitWidth;
3079       if FDayPos < M then
3080         M := FDayPos;
3081       if FDayPos > L then
3082         L := FDayPos;
3083     end;
3084 
3085     N := 3;
3086     K := 3;
3087     for DTP := dtpHour to dtpAMPM do begin
3088       I := Ord(DTP) + 1;
3089       if DTP in FEffectiveHideDateTimeParts then
3090         DD[I] := 0
3091       else if DTP = dtpAMPM then begin
3092         DD[I] := FAMPMWidth;
3093         N := I;
3094       end else begin
3095         if DTP = dtpMiliSec then
3096           DD[I] := 3 * FDigitWidth
3097         else
3098           DD[I] := 2 * FDigitWidth;
3099 
3100         if K < I then
3101           K := I;
3102       end;
3103 
3104       if N < K then
3105         N := K;
3106 
3107     end;
3108 
3109     for I := M to N do begin
3110       if DD[I] <> 0 then begin
3111 
3112         R.Right := R.Left + DD[I];
3113         if I <= 3 then begin
3114           if (I = FMonthPos) and FShowMonthNames then begin
3115             TextStyle.Alignment := taCenter;
3116             if DateIsNull then
3117               S := FNullMonthText
3118             else
3119               S := FTextPart[I];
3120           end else
3121             S := FTextPart[I];
3122 
3123         end else
3124           S := FTimeText[TDateTimePart(I - 1)];
3125 
3126         if I = SelectStep then begin
3127           TextStyle.Opaque := True;
3128           Canvas.Brush.Color := clHighlight;
3129           Canvas.Font.Color := clHighlightText;
3130 
3131           Canvas.TextRect(R, R.Left, R.Top, S, TextStyle);
3132 
3133           TextStyle.Opaque := False;
3134           Canvas.Brush.Color := Color;
3135           Canvas.Font.Color := Self.Font.Color;
3136         end else
3137           Canvas.TextRect(R, R.Left, R.Top, S, TextStyle);
3138 
3139         TextStyle.Alignment := taRightJustify;
3140         R.Left := R.Right;
3141 
3142         if I < L then begin
3143           R.Right := R.Left + FSeparatorWidth;
3144           if not ((I = FMonthPos) and FShowMonthNames) then
3145             Canvas.TextRect(R, R.Left, R.Top, FDateSeparator, TextStyle);
3146         end else if I > L then begin
3147           if I = K then begin
3148             R.Right := R.Left + FDigitWidth;
3149           end else if I < K then begin
3150             R.Right := R.Left + FTimeSeparatorWidth;
3151             Canvas.TextRect(R, R.Left, R.Top, FTimeSeparator, TextStyle);
3152           end;
3153         end else begin
3154           if FTrailingSeparator then begin
3155             R.Right := R.Left + FSepNoSpaceWidth;
3156             Canvas.TextRect(R, R.Left, R.Top,
3157                                       TrimRight(FDateSeparator), TextStyle);
3158           end;
3159           if FTimeWidth > 0 then
3160             R.Right := R.Right + 2 * FDigitWidth;
3161 
3162         end;
3163         R.Left := R.Right;
3164       end;
3165     end;
3166 
3167   end;
3168 
3169   inherited Paint;
3170 end;
3171 
3172 procedure TCustomDateTimePicker.EditingDone;
3173 begin
3174   if FNoEditingDone <= 0 then begin
3175     ConfirmChanges;
3176 
3177     inherited EditingDone;
3178   end;
3179 end;
3180 
3181 procedure TCustomDateTimePicker.ArrowMouseDown(Sender: TObject;
3182   Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
3183 begin
3184   DropDownCalendarForm;
3185 end;
3186 
3187 procedure TCustomDateTimePicker.UpDownClick(Sender: TObject;
3188   Button: TUDBtnType);
3189 begin
3190   SetFocusIfPossible;
3191 
3192   if not FReadOnly then begin
3193     Inc(FUserChanging);
3194     try
3195       if Button = btNext then
3196         IncreaseCurrentTextPart
3197       else
3198         DecreaseCurrentTextPart;
3199     finally
3200       Dec(FUserChanging);
3201     end;
3202   end;
3203 end;
3204 
3205 procedure TCustomDateTimePicker.DoDropDown;
3206 begin
3207   if Assigned(FOnDropDown) then
3208     FOnDropDown(Self);
3209 end;
3210 
3211 procedure TCustomDateTimePicker.DoCloseUp;
3212 begin
3213   if Assigned(FOnCloseUp) then
3214     FOnCloseUp(Self);
3215 end;
3216 
TCustomDateTimePicker.GetCheckednull3217 function TCustomDateTimePicker.GetChecked: Boolean;
3218 begin
3219   Result := not FShowCheckBox or FChecked;
3220 end;
3221 
TCustomDateTimePicker.AreSeparatorsStorednull3222 function TCustomDateTimePicker.AreSeparatorsStored: Boolean;
3223 begin
3224   Result := not FUseDefaultSeparators;
3225 end;
3226 
GetDatenull3227 function TCustomDateTimePicker.GetDate: TDate;
3228 begin
3229   if DateIsNull then
3230     Result := NullDate
3231   else
3232     Result := Int(FDateTime);
3233 end;
3234 
TCustomDateTimePicker.GetDateTimenull3235 function TCustomDateTimePicker.GetDateTime: TDateTime;
3236 begin
3237   if DateIsNull then
3238     Result := NullDate
3239   else
3240     Result := FDateTime;
3241 end;
3242 
GetDroppedDownnull3243 function TCustomDateTimePicker.GetDroppedDown: Boolean;
3244 begin
3245   Result := Assigned(FCalendarForm);
3246 end;
3247 
TCustomDateTimePicker.GetTimenull3248 function TCustomDateTimePicker.GetTime: TTime;
3249 begin
3250   if DateIsNull then
3251     Result := NullDate
3252   else
3253     Result := Abs(Frac(FDateTime));
3254 end;
3255 
3256 procedure TCustomDateTimePicker.SetArrowShape(const AValue: TArrowShape);
3257 begin
3258   if FArrowShape = AValue then Exit;
3259 
3260   FArrowShape := AValue;
3261   if FArrowButton<>nil then
3262     FArrowButton.Invalidate;
3263 end;
3264 
3265 procedure TCustomDateTimePicker.SetAutoButtonSize(AValue: Boolean);
3266 begin
3267   if FAutoButtonSize <> AValue then begin
3268     FAutoButtonSize := AValue;
3269 
3270     if AValue then
3271       AutoResizeButton
3272     else begin
3273       if Assigned(FUpDown) then
3274         FUpDown.Width := Scale96ToFont(DefaultUpDownWidth)
3275       else if Assigned(FArrowButton) then
3276         FArrowButton.Width := Scale96ToFont(DefaultArrowButtonWidth);
3277     end;
3278 
3279   end;
3280 end;
3281 
3282 procedure TCustomDateTimePicker.SetCalAlignment(AValue: TDTCalAlignment);
3283 begin
3284   if FCalAlignment = AValue then Exit;
3285   FCalAlignment := AValue;
3286 end;
3287 
3288 procedure TCustomDateTimePicker.SetCalendarWrapperClass(
3289   AValue: TCalendarControlWrapperClass);
3290 begin
3291   if FCalendarWrapperClass = AValue then Exit;
3292   FCalendarWrapperClass := AValue;
3293 end;
3294 
3295 procedure TCustomDateTimePicker.SetCenturyFrom(const AValue: Word);
3296 begin
3297   if FCenturyFrom = AValue then Exit;
3298 
3299   FCenturyFrom := AValue;
3300   AdjustEffectiveCenturyFrom;
3301 end;
3302 
3303 procedure TCustomDateTimePicker.CheckBoxChange;
3304 begin
3305   if Assigned(FOnCheckBoxChange) then
3306     FOnCheckBoxChange(Self);
3307 
3308   if FOnCheckBoxChangeHandlers<>nil then
3309     FOnCheckBoxChangeHandlers.CallNotifyEvents(Self);
3310 end;
3311 
3312 procedure TCustomDateTimePicker.SetFocusIfPossible;
3313 var
3314   F: TCustomForm;
3315 
3316 begin
3317   Inc(FNoEditingDone);
3318   try
3319     F := GetParentForm(Self);
3320 
3321     if Assigned(F) and F.CanFocus and CanTab then
3322       SetFocus;
3323 
3324   finally
3325     Dec(FNoEditingDone);
3326   end;
3327 end;
3328 
3329 procedure TCustomDateTimePicker.AutoResizeButton;
3330 begin
3331   if Assigned(FArrowButton) then
3332     FArrowButton.Width := MulDiv(ClientHeight, 9, 10)
3333   else if Assigned(FUpDown) then
3334     FUpDown.Width := MulDiv(ClientHeight, 79, 100);
3335 end;
3336 
3337 procedure TCustomDateTimePicker.CheckAndApplyKey(const Key: Char);
3338 var
3339   S: String;
3340   DTP: TDateTimePart;
3341   N, L: Integer;
3342   YMD: TYMD;
3343   HMSMs: THMSMs;
3344   D, T: TDateTime;
3345   Finished, ForceChange: Boolean;
3346 
3347 begin
3348   if (not FReadOnly) then begin
3349     Finished := False;
3350     ForceChange := False;
3351 
3352     if FSelectedTextPart = 8 then begin
3353       case upCase(Key) of
3354         'A': S := 'AM';
3355         'P': S := 'PM';
3356       else
3357         Finished := True;
3358       end;
3359       ForceChange := True;
3360 
3361     end else if Key in ['0'..'9'] then begin
3362 
3363       DTP := GetSelectedDateTimePart;
3364 
3365       if DTP = dtpYear then
3366         N := 4
3367       else if DTP = dtpMiliSec then
3368         N := 3
3369       else
3370         N := 2;
3371 
3372       S := Trim(GetSelectedText);
3373       if FUserChangedText and (Length(S) < N) then
3374         S := S + Key
3375       else
3376         S := Key;
3377 
3378       if (Length(S) >= N) then begin
3379 
3380         FCorrectedDTP := dtpAMPM;
3381 
3382         L := StrToInt(S);
3383         if DTP < dtpHour then begin
3384           YMD := GetYYYYMMDD(True);
3385           case DTP of
3386             dtpDay: YMD.Day := L;
3387             dtpMonth: YMD.Month := L;
3388             dtpYear: YMD.Year := L;
3389           end;
3390 
3391           if AutoAdvance and (YMD.Day <= 31) and
3392               (YMD.Day > NumberOfDaysInMonth(YMD.Month, YMD.Year)) then begin
3393             case DTP of
3394               dtpDay:
3395                 case FEffectiveDateDisplayOrder of
3396                   ddoDMY: begin
3397                     FCorrectedValue := YMD.Month + 1;
3398                     FCorrectedDTP := dtpMonth;
3399                   end;
3400                   ddoMDY:
3401                     FCorrectedDTP := dtpYear;
3402                 end;
3403               dtpMonth:
3404                 case FEffectiveDateDisplayOrder of
3405                   ddoMDY, ddoYMD: begin
3406                       FCorrectedValue := NumberOfDaysInMonth(YMD.Month, YMD.Year);
3407                       FCorrectedDTP := dtpDay;
3408                     end;
3409                   ddoDMY:
3410                     FCorrectedDTP := dtpYear;
3411                 end;
3412               dtpYear:
3413                 if (FEffectiveDateDisplayOrder = ddoYMD) and (YMD.Month = 2)
3414                       and (YMD.Day = 29) and not IsLeapYear(YMD.Year) then begin
3415                   FCorrectedValue := YMD.Month + 1;
3416                   FCorrectedDTP := dtpMonth;
3417                 end;
3418             end;
3419 
3420             case FCorrectedDTP of
3421               dtpDay:
3422                 YMD.Day := FCorrectedValue;
3423               dtpMonth:
3424                 YMD.Month := FCorrectedValue;
3425               dtpYear:
3426                 if (YMD.Day = 29) and (YMD.Month = 2) then begin
3427                   while not IsLeapYear(YMD.Year) do
3428                     Inc(YMD.Year);
3429                   FCorrectedValue := YMD.Year;
3430                 end;
3431 
3432             end;
3433           end;
3434 
3435           if TryEncodeDate(YMD.Year, YMD.Month, YMD.Day, D)
3436                     and (D >= MinDate) and (D <= MaxDate) then
3437             ForceChange := True
3438           else if N = 4 then begin
3439             UpdateDate;
3440             Finished := True;
3441           end else
3442             S := Key;
3443 
3444         end else begin
3445           if (DTP = dtpHour) and (FTimeFormat = tf12) then begin
3446             if not (L in [1..12]) then
3447               S := Key
3448             else
3449               ForceChange := True;
3450 
3451           end else begin
3452 
3453             HMSMs := GetHMSMs(True);
3454             case DTP of
3455               dtpHour: HMSMs.Hour := L;
3456               dtpMinute: HMSMs.Minute := L;
3457               dtpSecond: HMSMs.Second := L;
3458               dtpMiliSec: HMSMs.MiliSec := L;
3459             end;
3460             if not TryEncodeTime(HMSMs.Hour, HMSMs.Minute, HMSMs.Second,
3461                                          HMSMs.MiliSec, T) then
3462               S := Key
3463             else
3464               ForceChange := True;
3465 
3466           end;
3467         end;
3468 
3469       end;
3470     end else
3471       Finished := True;
3472 
3473     if (not Finished) and (GetSelectedText <> S) then begin
3474       if (not FUserChangedText) and DateIsNull then
3475         if FSelectedTextPart <= 3 then
3476           DateTime := SysUtils.Date
3477         else
3478           DateTime := SysUtils.Now;
3479 
3480       if (not FLeadingZeros) and (FSelectedTextPart <= 4) then
3481         while (Length(S) > 1) and (S[1] = '0') do
3482           Delete(S, 1, 1);
3483 
3484       if FSelectedTextPart <= 3 then
3485         FTextPart[FSelectedTextPart] := S
3486       else
3487         FTimeText[TDateTimePart(FSelectedTextPart - 1)] := S;
3488 
3489       FUserChangedText := True;
3490 
3491       if ForceChange then begin
3492         if FAutoAdvance then begin
3493           MoveSelectionLR(False);
3494           Invalidate;
3495         end else
3496           UpdateIfUserChangedText;
3497       end else
3498         Invalidate;
3499 
3500       DoAutoCheck;
3501     end;
3502 
3503     FCorrectedDTP := dtpAMPM;
3504   end;
3505 
3506 end;
3507 
3508 procedure TCustomDateTimePicker.CheckAndApplyKeyCode(var Key: Word);
3509 var
3510   K: Word;
3511 begin
3512   if (Key = VK_SPACE) then begin
3513     if ShowCheckBox then
3514       Checked := not Checked;
3515 
3516   end else if FTextEnabled then begin
3517 
3518     case Key of
3519       VK_LEFT, VK_RIGHT, VK_OEM_COMMA, VK_OEM_PERIOD, VK_DIVIDE,
3520           VK_OEM_MINUS, VK_SEPARATOR, VK_DECIMAL, VK_SUBTRACT:
3521         begin
3522           K := Key;
3523           Key := 0;
3524           MoveSelectionLR(K = VK_LEFT);
3525           Invalidate;
3526         end;
3527       VK_UP:
3528         begin
3529           Key := 0;
3530           UpdateIfUserChangedText;
3531           if not FReadOnly then
3532           begin
3533             IncreaseCurrentTextPart;
3534             DoAutoCheck;
3535           end;
3536         end;
3537       VK_DOWN:
3538         begin
3539           Key := 0;
3540           UpdateIfUserChangedText;
3541           if not FReadOnly then
3542           begin
3543             DecreaseCurrentTextPart;
3544             DoAutoCheck;
3545           end;
3546         end;
3547       VK_RETURN:
3548         if not FReadOnly then
3549           EditingDone;
3550 
3551       VK_ESCAPE:
3552         if not FReadOnly then begin
3553           UndoChanges;
3554           EditingDone;
3555         end;
3556       VK_N:
3557         if (not FReadOnly) and FNullInputAllowed then
3558           SetDateTime(NullDate);
3559     end;
3560 
3561   end;
3562 
3563 end;
3564 
3565 procedure TCustomDateTimePicker.WMKillFocus(var Message: TLMKillFocus);
3566 begin
3567   // On Qt it seems that WMKillFocus happens even when focus jumps to some other
3568   // form. This behaviour differs from win and gtk 2 (where it happens only when
3569   // focus jumps to other control on the same form) and we should prevent it at
3570   // least for our calendar, because it triggers EditingDone.
3571   if Screen.ActiveCustomForm <> FCalendarForm then
3572     inherited WMKillFocus(Message);
3573 end;
3574 
3575 procedure TCustomDateTimePicker.WMSize(var Message: TLMSize);
3576 begin
3577   inherited WMSize(Message);
3578 
3579   if FAutoButtonSize then
3580     AutoResizeButton;
3581 end;
3582 
3583 procedure TCustomDateTimePicker.DropDownCalendarForm;
3584 begin
3585   SetFocusIfPossible;
3586 
3587   if FAllowDroppingCalendar then begin
3588     if not (FReadOnly or Assigned(FCalendarForm)
3589                           or (csDesigning in ComponentState)) then begin
3590       FCalendarForm := TDTCalendarForm.CreateNewDTCalendarForm(nil, Self);
3591       FCalendarForm.Show;
3592     end;
3593 
3594   end else begin
3595     DestroyCalendarForm;
3596     FAllowDroppingCalendar := True;
3597   end;
3598 
3599 end;
3600 
3601 { TDTUpDown }
3602 
3603 { When our UpDown control gets enabled/disabled, the two its buttons' Enabled
3604   property is set accordingly. }
3605 procedure TDTUpDown.SetEnabled(Value: Boolean);
3606 
3607   procedure SetEnabledForAllChildren(AWinControl: TWinControl);
3608   var
3609     I: Integer;
3610     C: TControl;
3611   begin
3612     for I := 0 to AWinControl.ControlCount - 1 do begin
3613       C := AWinControl.Controls[I];
3614       C.Enabled := Value;
3615 
3616       if C is TWinControl then
3617         SetEnabledForAllChildren(TWinControl(C));
3618 
3619     end;
3620   end;
3621 
3622 begin
3623   inherited SetEnabled(Value);
3624 
3625   SetEnabledForAllChildren(Self);
3626 end;
3627 
3628 { Our UpDown control is always alligned, but setting its PreferredHeight
3629   uncoditionally to 1 prevents the UpDown to mess with our PreferredHeight.
3630   The problem is that if we didn't do this, when our Height is greater than
3631   really preffered, UpDown prevents it to be set correctly when we set AutoSize
3632   to True. }
3633 procedure TDTUpDown.CalculatePreferredSize(var PreferredWidth, PreferredHeight:
3634   integer; WithThemeSpace: Boolean);
3635 begin
3636   inherited CalculatePreferredSize(PreferredWidth, PreferredHeight,
3637     WithThemeSpace);
3638 
3639   PreferredHeight := 1;
3640 end;
3641 
3642 { We don't want to let EditingDone event to fire each time up-down buttons get
3643   clicked. That is why WndProc is overriden. }
3644 procedure TDTUpDown.WndProc(var Message: TLMessage);
3645 begin
3646   if ((Message.msg >= LM_MOUSEFIRST) and (Message.msg <= LM_MOUSELAST))
3647       or ((Message.msg >= LM_MOUSEFIRST2) and (Message.msg <= LM_MOUSELAST2)) then begin
3648 
3649     Inc(DTPicker.FNoEditingDone);
3650     try
3651       inherited WndProc(Message);
3652     finally
3653       Dec(DTPicker.FNoEditingDone);
3654     end
3655 
3656   end else
3657     inherited WndProc(Message);
3658 
3659 end;
3660 
3661 { TDTSpeedButton }
3662 
3663 { See the coment above TDTUpDown.CalculatePreferredSize }
3664 procedure TDTSpeedButton.CalculatePreferredSize(var PreferredWidth,
3665   PreferredHeight: integer; WithThemeSpace: Boolean);
3666 begin
3667   inherited CalculatePreferredSize(PreferredWidth, PreferredHeight,
3668     WithThemeSpace);
3669 
3670   PreferredHeight := 1;
3671 end;
3672 
3673 { Prevent EditingDone to fire whenever the SpeedButton gets clicked }
3674 procedure TDTSpeedButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
3675   Y: Integer);
3676 begin
3677   Inc(DTPicker.FNoEditingDone);
3678   try
3679     inherited MouseDown(Button, Shift, X, Y);
3680   finally
3681     Dec(DTPicker.FNoEditingDone);
3682   end;
3683 end;
3684 
3685 procedure TDTSpeedButton.Paint;
3686   procedure DrawDropDownArrow(const Canvas: TCanvas; const DropDownButtonRect: TRect);
3687   var
3688     Details: TThemedElementDetails;
3689     ArrowState: TThemedToolBar;
3690     ASize: TSize;
3691     ARect: TRect;
3692   begin
3693     if Enabled then
3694       ArrowState := ttbSplitButtonDropDownNormal
3695     else
3696       ArrowState := ttbSplitButtonDropDownDisabled;
3697     Details := ThemeServices.GetElementDetails(ArrowState);
3698     ASize := ThemeServices.GetDetailSize(Details);
3699     ARect := DropDownButtonRect;
3700     InflateRect(ARect, -(ARect.Right-ARect.Left-ASize.cx) div 2, 0);
3701     ThemeServices.DrawElement(Canvas.Handle, Details, ARect);
3702   end;
3703 const
3704   ArrowColor = TColor($8D665A);
3705 var
3706   X, Y: Integer;
3707 begin
3708   inherited Paint;
3709 
3710   // First I ment to put arrow images in a lrs file. In my opinion, however, that
3711   // wouldn't be an elegant option for so simple shapes.
3712 
3713   Canvas.Brush.Style := bsSolid;
3714   Canvas.Pen.Color := ArrowColor;
3715   Canvas.Brush.Color := Canvas.Pen.Color;
3716 
3717   X := (Width-9) div 2;
3718   Y := (Height-6) div 2;
3719 
3720 { Let's draw shape of the arrow on the button: }
3721   case DTPicker.FArrowShape of
3722     asTheme:
3723       DrawDropDownArrow(Canvas, Rect(0, 0, Width, Height));
3724 
3725     asClassicLarger:
3726       { triangle: }
3727       Canvas.Polygon([Point(X+0, Y+1), Point(X+8, Y+1),
3728                                                       Point(X+4, Y+5)]);
3729     asClassicSmaller:
3730       { triangle -- smaller variant:  }
3731       Canvas.Polygon([Point(X+1, Y+2), Point(X+7, Y+2),
3732                                                       Point(X+4, Y+5)]);
3733     asModernLarger:
3734       { modern: }
3735       Canvas.Polygon([Point(X+0, Y+1), Point(X+1, Y+0),
3736                         Point(X+4, Y+3), Point(X+7, Y+0), Point(X+8, Y+1), Point(X+4, Y+5)]);
3737     asModernSmaller:
3738       { modern -- smaller variant:    }
3739       Canvas.Polygon([Point(X+1, Y+2), Point(X+2, Y+1),
3740                         Point(X+4, Y+3), Point(X+6, Y+1), Point(X+7, Y+2), Point(X+4, Y+5)]);
3741     asYetAnotherShape:
3742       { something in between, not very pretty:  }
3743       Canvas.Polygon([Point(X+0, Y+1), Point(X+1, Y+0),
3744             Point(X+2, Y+1), Point(X+6, Y+1),Point(X+7, Y+0), Point(X+8, Y+1), Point(X+4, Y+5)]);
3745   end;
3746 end;
3747 
3748 procedure TCustomDateTimePicker.UpdateShowArrowButton;
3749 
3750   procedure CreateArrowBtn;
3751   begin
3752     if not Assigned(FArrowButton) then begin
3753       DestroyCalendarForm;
3754       DestroyUpDown;
3755 
3756       FArrowButton := TDTSpeedButton.Create(Self);
3757       FArrowButton.ControlStyle := FArrowButton.ControlStyle +
3758                                             [csNoFocus, csNoDesignSelectable];
3759       FArrowButton.Flat := dtpoFlatButton in Options;
3760       TDTSpeedButton(FArrowButton).DTPicker := Self;
3761       FArrowButton.SetBounds(0, 0, Scale96ToFont(DefaultArrowButtonWidth), 1);
3762 
3763       FArrowButton.Parent := Self;
3764       FAllowDroppingCalendar := True;
3765 
3766       TDTSpeedButton(FArrowButton).OnMouseDown := @ArrowMouseDown;
3767 
3768     end;
3769   end;
3770 
3771   procedure CreateUpDown;
3772   begin
3773     if not Assigned(FUpDown) then begin
3774       DestroyArrowBtn;
3775 
3776       FUpDown := TDTUpDown.Create(Self);
3777       FUpDown.ControlStyle := FUpDown.ControlStyle +
3778                                      [csNoFocus, csNoDesignSelectable];
3779 
3780       TDTUpDown(FUpDown).DTPicker := Self;
3781       TDTUpDown(FUpDown).Flat := dtpoFlatButton in Options;
3782 
3783       FUpDown.SetBounds(0, 0, Scale96ToFont(DefaultUpDownWidth), 1);
3784 
3785       FUpDown.Parent := Self;
3786 
3787       TDTUpDown(FUPDown).OnClick := @UpDownClick;
3788 
3789     end;
3790   end;
3791 
3792 var
3793   ReallyShowArrowButton: Boolean;
3794 
3795 begin
3796   if FDateMode = dmNone then begin
3797     DestroyArrowBtn;
3798     DestroyUpDown;
3799 
3800   end else begin
3801     ReallyShowArrowButton := (FDateMode = dmComboBox) and
3802                           not (dtpDay in FEffectiveHideDateTimeParts);
3803 
3804     if (ReallyShowArrowButton <> Assigned(FArrowButton)) or
3805                        (Assigned(FArrowButton) = Assigned(FUpDown)) then begin
3806       DisableAlign;
3807       try
3808         if ReallyShowArrowButton then
3809           CreateArrowBtn
3810         else
3811           CreateUpDown;
3812 
3813         ArrangeCtrls;
3814 
3815       finally
3816         EnableAlign;
3817       end;
3818     end;
3819 
3820   end;
3821 end;
3822 
3823 procedure TCustomDateTimePicker.DestroyUpDown;
3824 begin
3825   if Assigned(FUpDown) then begin
3826     TDTUpDown(FUPDown).OnClick := nil;
3827     FreeAndNil(FUpDown);
3828   end;
3829 end;
3830 
3831 procedure TCustomDateTimePicker.DoAutoCheck;
3832 begin
3833   if ShowCheckBox and not Checked and (dtpoAutoCheck in Options) then
3834     Checked := True;
3835 end;
3836 
3837 procedure TCustomDateTimePicker.DoAutoAdjustLayout(
3838   const AMode: TLayoutAdjustmentPolicy;
3839   const AXProportion, AYProportion: Double);
3840 begin
3841   inherited;
3842   if AMode in [lapAutoAdjustWithoutHorizontalScrolling, lapAutoAdjustForDPI] then
3843   begin
3844     if (not FAutoButtonSize) then begin
3845       if Assigned(FArrowButton) then
3846         FArrowButton.Width := Scale96ToFont(DefaultArrowButtonWidth);
3847       if Assigned(FUpDown) then
3848         FUpDown.Width := Scale96ToFont(DefaultUpdownWidth);
3849     end;
3850   end;
3851 end;
3852 
3853 procedure TCustomDateTimePicker.DestroyArrowBtn;
3854 begin
3855   if Assigned(FArrowButton) then begin
3856     TDTSpeedButton(FArrowButton).OnMouseDown := nil;
3857     DestroyCalendarForm;
3858     FreeAndNil(FArrowButton);
3859   end;
3860 end;
3861 
3862 constructor TCustomDateTimePicker.Create(AOwner: TComponent);
3863 var
3864   I: Integer;
3865   DTP: TDateTimePart;
3866 begin
3867   inherited Create(AOwner);
3868 
3869   with GetControlClassDefaultSize do
3870     SetInitialBounds(0, 0, cx, cy);
3871 
3872   FCalAlignment := dtaDefault;
3873   FCorrectedDTP := dtpAMPM;
3874   FCorrectedValue := 0;
3875   FSkipChangeInUpdateDate := 0;
3876   FNoEditingDone := 0;
3877   FArrowShape := asTheme;
3878   FAllowDroppingCalendar := True;
3879   FChecked := True;
3880 
3881   FOnDropDown := nil;
3882   FOnCloseUp := nil;
3883 
3884   ParentColor := False;
3885   FArrowButton := nil;
3886   FUpDown := nil;
3887 
3888   FKind := dtkDate;
3889   FNullInputAllowed := True;
3890   FOptions := cDefOptions;
3891 
3892   { Thanks to Luiz Américo for this:
3893     Lazarus ignores empty string when saving to lrs. Therefore, the problem
3894     is, when TextForNullDate is set to an empty string and after the project
3895     is saved and opened again, then, this property gets default value NULL
3896     instead of empty string. The following condition seems to be a workaround
3897     for this. }
3898   if (AOwner = nil) or not (csReading in Owner.ComponentState) then
3899     FTextForNullDate := 'NULL';
3900 
3901   FCenturyFrom := 1941;
3902   FRecalculatingTextSizesNeeded := True;
3903   FOnChange := nil;
3904   FOnCheckBoxChange := nil;
3905   FSeparatorWidth := 0;
3906   FSepNoSpaceWidth := 0;
3907   FDigitWidth := 0;
3908   FTimeSeparatorWidth := 0;
3909   FAMPMWidth := 0;
3910   FDateWidth := 0;
3911   FTimeWidth := 0;
3912   FTextWidth := 0;
3913   FTextHeight := 0;
3914   FMonthWidth := 0;
3915   FHideDateTimeParts := [];
3916   FShowMonthNames := False;
3917   FNullMonthText := '';
3918 
3919   for I := Low(FTextPart) to High(FTextPart) do
3920     FTextPart[I] := '';
3921 
3922   for DTP := dtpHour to dtpAMPM do
3923     FTimeText[DTP] := '';
3924 
3925   FTimeDisplay := tdHMS;
3926   FTimeFormat := tf24;
3927 
3928   FLeadingZeros := True;
3929   FUserChanging := 0;
3930   FReadOnly := False;
3931   FDateTime := SysUtils.Now;
3932   FConfirmedDateTime := FDateTime;
3933   FMinDate := TheSmallestDate;
3934   FMaxDate := TheBiggestDate;
3935   FTrailingSeparator := False;
3936   FDateDisplayOrder := ddoTryDefault;
3937   FSelectedTextPart := 1;
3938   FUseDefaultSeparators := True;
3939   FDateSeparator := DefaultFormatSettings.DateSeparator;
3940   FTimeSeparator := DefaultFormatSettings.TimeSeparator;
3941   FEffectiveCenturyFrom := FCenturyFrom;
3942   FJumpMinMax := False;
3943 
3944   ParentColor := False;
3945   TabStop := True;
3946   BorderWidth := 2;
3947   BorderStyle := bsSingle;
3948   ParentFont := True;
3949   AutoSize := True;
3950 
3951   FTextEnabled := True;
3952   FCalendarForm := nil;
3953   FDoNotArrangeControls := True;
3954   FCascade := False;
3955   FAutoButtonSize := False;
3956   FAutoAdvance := True;
3957   FCalendarWrapperClass := nil;
3958   FEffectiveHideDateTimeParts := [];
3959 
3960   AdjustEffectiveDateDisplayOrder;
3961   AdjustEffectiveHideDateTimeParts;
3962 
3963   SetMonthNames('Long');
3964   SetDateMode(dmComboBox);
3965 end;
3966 
3967 procedure TCustomDateTimePicker.AddHandlerOnChange(
3968   const AOnChange: TNotifyEvent; AsFirst: Boolean);
3969 begin
3970   if FOnChangeHandlers=nil then
3971     FOnChangeHandlers := TMethodList.Create;
3972   FOnChangeHandlers.Add(TMethod(AOnChange), not AsFirst);
3973 end;
3974 
3975 procedure TCustomDateTimePicker.AddHandlerOnCheckBoxChange(
3976   const AOnCheckBoxChange: TNotifyEvent; AsFirst: Boolean);
3977 begin
3978   if FOnCheckBoxChangeHandlers=nil then
3979     FOnCheckBoxChangeHandlers := TMethodList.Create;
3980   FOnCheckBoxChangeHandlers.Add(TMethod(AOnCheckBoxChange), not AsFirst);
3981 end;
3982 
3983 procedure TCustomDateTimePicker.RemoveHandlerOnChange(AOnChange: TNotifyEvent);
3984 begin
3985   if Assigned(FOnChangeHandlers) then
3986     FOnChangeHandlers.Remove(TMethod(AOnChange));
3987 end;
3988 
3989 procedure TCustomDateTimePicker.RemoveHandlerOnCheckBoxChange(
3990   AOnCheckBoxChange: TNotifyEvent);
3991 begin
3992   if Assigned(FOnCheckBoxChangeHandlers) then
3993     FOnCheckBoxChangeHandlers.Remove(TMethod(AOnCheckBoxChange));
3994 end;
3995 
3996 destructor TCustomDateTimePicker.Destroy;
3997 begin
3998   FDoNotArrangeControls := True;
3999   DestroyArrowBtn;
4000   DestroyUpDown;
4001   SetShowCheckBox(False);
4002   FOnChangeHandlers.Free;
4003   FOnCheckBoxChangeHandlers.Free;
4004 
4005   inherited Destroy;
4006 end;
4007 
TCustomDateTimePicker.DateIsNullnull4008 function TCustomDateTimePicker.DateIsNull: Boolean;
4009 begin
4010   Result := IsNullDate(FDateTime);
4011 end;
4012 
4013 end.
4014