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