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