source: cprs/branches/GUI-config/CPRS-Lib/ORDtTm.pas@ 486

Last change on this file since 486 was 476, checked in by Kevin Toppenberg, 16 years ago

New WorldVistA Config Utility
File size: 35.7 KB
Line 
1unit ORDtTm;
2
3{$O-}
4
5interface
6
7uses
8 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Buttons,
9 Grids, Calendar, ExtCtrls, ORFn, ORNet, ORDtTmCal, Mask, ComCtrls, ORCtrls;
10
11type
12 TORfrmDtTm = class(TForm)
13 bvlFrame: TBevel;
14 lblDate: TPanel;
15 txtTime: TEdit;
16 lstHour: TListBox;
17 lstMinute: TListBox;
18 cmdOK: TButton;
19 cmdCancel: TButton;
20 calSelect: TORCalendar;
21 pnlPrevMonth: TPanel;
22 pnlNextMonth: TPanel;
23 imgPrevMonth: TImage;
24 imgNextMonth: TImage;
25 bvlRButton: TBevel;
26 cmdToday: TButton;
27 cmdNow: TButton;
28 cmdMidnight: TButton;
29 procedure FormCreate(Sender: TObject);
30 procedure calSelectChange(Sender: TObject);
31 procedure cmdTodayClick(Sender: TObject);
32 procedure txtTimeChange(Sender: TObject);
33 procedure lstHourClick(Sender: TObject);
34 procedure lstMinuteClick(Sender: TObject);
35 procedure cmdNowClick(Sender: TObject);
36 procedure cmdOKClick(Sender: TObject);
37 procedure cmdCancelClick(Sender: TObject);
38 procedure imgPrevMonthClick(Sender: TObject);
39 procedure imgNextMonthClick(Sender: TObject);
40 procedure imgPrevMonthMouseDown(Sender: TObject; Button: TMouseButton;
41 Shift: TShiftState; X, Y: Integer);
42 procedure imgNextMonthMouseDown(Sender: TObject; Button: TMouseButton;
43 Shift: TShiftState; X, Y: Integer);
44 procedure imgPrevMonthMouseUp(Sender: TObject; Button: TMouseButton;
45 Shift: TShiftState; X, Y: Integer);
46 procedure imgNextMonthMouseUp(Sender: TObject; Button: TMouseButton;
47 Shift: TShiftState; X, Y: Integer);
48 procedure cmdMidnightClick(Sender: TObject);
49 private
50 FFromSelf: Boolean;
51 FNowPressed: Boolean;
52 TimeIsRequired: Boolean;
53 end;
54
55 { TORDateTimeDlg }
56
57 TORDateTimeDlg = class(TComponent)
58 private
59 FDateTime: TDateTime;
60 FDateOnly: Boolean;
61 FRequireTime: Boolean;
62 FRelativeTime: string;
63 function GetFMDateTime: TFMDateTime;
64 procedure SetDateOnly(Value: Boolean);
65 procedure SetFMDateTime(Value: TFMDateTime);
66 procedure SetRequireTime(Value: Boolean);
67 public
68 constructor Create(AOwner: TComponent); override;
69 function Execute: Boolean;
70 property RelativeTime: string read FRelativeTime;
71 published
72 property FMDateTime: TFMDateTime read GetFMDateTime write SetFMDateTime;
73 property DateOnly: Boolean read FDateOnly write SetDateOnly;
74 property RequireTime: Boolean read FRequireTime write SetRequireTime;
75 end;
76
77 { TORDateBox }
78
79 TORDateEdit = class(TEdit)
80 protected
81 procedure CreateParams(var Params: TCreateParams); override;
82 end;
83
84 TORDateBox = class(TORDateEdit)
85 private
86 FFMDateTime: TFMDateTime;
87 FDateOnly: Boolean;
88 FRequireTime: Boolean;
89 FButton: TBitBtn;
90 FFormat: string;
91 FTimeIsNow: Boolean;
92 FTemplateField: boolean;
93 FCaption: TStaticText;
94 procedure ButtonClick(Sender: TObject);
95 function GetFMDateTime: TFMDateTime;
96 function GetRelativeTime: string;
97 procedure SetDateOnly(Value: Boolean);
98 procedure SetFMDateTime(Value: TFMDateTime);
99 procedure SetEditRect;
100 procedure SetRequireTime(Value: Boolean);
101 procedure UpdateText;
102 procedure WMSize(var Message: TWMSize); message WM_SIZE;
103 procedure SetTemplateField(const Value: boolean);
104 procedure SetCaption(const Value: string);
105 function GetCaption(): string;
106
107 protected
108 procedure Change; override;
109 procedure KeyDown(var Key: Word; Shift: TShiftState); override;
110 public
111 constructor Create(AOwner: TComponent); override;
112 function IsValid: Boolean;
113 procedure Validate(var ErrMsg: string);
114 property Format: string read FFormat write FFormat;
115 property RelativeTime: string read GetRelativeTime;
116 property TemplateField: boolean read FTemplateField write SetTemplateField;
117 published
118 property FMDateTime: TFMDateTime read GetFMDateTime write SetFMDateTime;
119 property DateOnly: Boolean read FDateOnly write SetDateOnly;
120 property RequireTime: Boolean read FRequireTime write SetRequireTime;
121 property Caption: string read GetCaption write SetCaption;
122 end;
123
124 TORDateCombo = class(TCustomPanel)
125 private
126 FYearChanging: boolean;
127 FMonthCombo: TORComboBox;
128 FDayCombo: TORComboBox;
129 FYearEdit: TMaskEdit;
130 FYearUD: TUpDown;
131 FCalBtn: TSpeedButton;
132 FIncludeMonth: boolean;
133 FIncludeDay: boolean;
134 FIncludeBtn: boolean;
135 FLongMonths: boolean;
136 FMonth: integer;
137 FDay: integer;
138 FYear: integer;
139 FCtrlsCreated: boolean;
140 FOnChange: TNotifyEvent;
141 FRebuilding: boolean;
142 FTemplateField: boolean;
143 procedure SetIncludeBtn(const Value: boolean);
144 procedure SetIncludeDay(Value: boolean);
145 procedure SetIncludeMonth(const Value: boolean);
146 procedure SetLongMonths(const Value: boolean);
147 procedure SetDay(Value: integer);
148 procedure SetMonth(Value: integer);
149 procedure SetYear(const Value: integer);
150 function GetFMDate: TFMDateTime;
151 procedure SetFMDate(const Value: TFMDateTime);
152 procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
153 procedure SetTemplateField(const Value: boolean);
154 protected
155 procedure Rebuild;
156 function InitDays(GetSize: boolean): integer;
157 function InitMonths(GetSize: boolean): integer;
158 function GetYearSize: integer;
159 procedure DoChange;
160 procedure MonthChanged(Sender: TObject);
161 procedure DayChanged(Sender: TObject);
162 procedure YearChanged(Sender: TObject);
163 procedure BtnClicked(Sender: TObject);
164 procedure YearUDChange(Sender: TObject; var AllowChange: Boolean;
165 NewValue: Smallint; Direction: TUpDownDirection);
166 procedure YearKeyPress(Sender: TObject; var Key: Char);
167 procedure CheckDays;
168 procedure Loaded; override;
169 procedure Paint; override;
170 procedure Resized(Sender: TObject);
171 public
172 constructor Create(AOwner: TComponent); override;
173 destructor Destroy; override;
174 function DateText: string;
175 property TemplateField: boolean read FTemplateField write SetTemplateField;
176 published
177 function Text: string;
178 property IncludeBtn: boolean read FIncludeBtn write SetIncludeBtn;
179 property IncludeDay: boolean read FIncludeDay write SetIncludeDay;
180 property IncludeMonth: boolean read FIncludeMonth write SetIncludeMonth;
181 property LongMonths: boolean read FLongMonths write SetLongMonths default FALSE;
182 property FMDate: TFMDateTime read GetFMDate write SetFMDate;
183 property Month: integer read FMonth write SetMonth;
184 property Day: integer read FDay write SetDay;
185 property Year: integer read FYear write SetYear;
186 property OnChange: TNotifyEvent read FOnChange write FOnChange;
187 property Anchors;
188 property Enabled;
189 property Font;
190 property ParentColor;
191 property ParentFont;
192 property TabOrder;
193 property TabStop;
194 property Visible;
195 end;
196
197function IsLeapYear(AYear: Integer): Boolean;
198function DaysPerMonth(AYear, AMonth: Integer): Integer;
199
200procedure Register;
201
202implementation
203
204{$R *.DFM}
205{$R ORDtTm}
206
207const
208 FMT_DATETIME = 'mmm d,yyyy@hh:nn';
209 FMT_DATEONLY = 'mmm d,yyyy';
210 (*
211 HOURS_AMPM: array[0..23] of string[3] =
212 ('12a',' 1',' 2',' 3',' 4',' 5',' 6',' 7',' 8',' 9','10 ','11 ',
213 '12p',' 1',' 2',' 3',' 4',' 5',' 6',' 7',' 8',' 9','10 ','11 ');
214 HOURS_MIL: array[0..23] of string[2] =
215 ('00','01','02','03','04','05','06','07','08','09','10','11',
216 '12','13','14','15','16','17','18','19','20','21','22','23');
217 *)
218 AdjVertSize = 8;
219 FontHeightText = 'BEFHILMSTVWXZfgjmpqtyk';
220
221var
222 uServerToday: TFMDateTime;
223
224{ Server-dependent functions ---------------------------------------------------------------- }
225
226function ActiveBroker: Boolean;
227begin
228 Result := False;
229 if (RPCBrokerV <> nil) and RPCBrokerV.Connected then Result := True;
230end;
231
232function ServerFMNow: TFMDateTime;
233begin
234 if ActiveBroker
235 then Result := StrToFloat(sCallV('ORWU DT', ['NOW']))
236 else Result := DateTimeToFMDateTime(Now);
237end;
238
239function ServerNow: TDateTime;
240begin
241 if ActiveBroker
242 then Result := FMDateTimeToDateTime(ServerFMNow)
243 else Result := Now;
244end;
245
246function ServerToday: TDateTime;
247begin
248 if uServerToday = 0 then uServerToday := Int(ServerFMNow);
249 Result := FMDateTimeToDateTime(uServerToday);
250end;
251
252(*
253function ServerFMToday: TFMDateTime; // never referenced in this unit
254begin
255 if uServerToday = 0 then uServerToday := Int(ServerFMNow);
256 Result := uServerToday;
257end;
258*)
259
260function ServerParseFMDate(const AString: string): TFMDateTime;
261begin
262 if ActiveBroker
263 then Result := StrToFloat(sCallV('ORWU DT', [AString, 'TSX']))
264 else Result := 0;
265end;
266
267function RelativeDateTime(ADateTime: TDateTime): string;
268var
269 Offset: Integer;
270 h,n,s,l: Word;
271 ATime: string;
272begin
273 Offset := Trunc(Int(ADateTime) - Int(ServerToday));
274 if Offset < 0 then Result := 'T' + IntToStr(Offset)
275 else if Offset = 0 then Result := 'T'
276 else Result := 'T+' + IntToStr(Offset);
277 DecodeTime(ADateTime, h, n, s, l);
278 ATime := Format('@%.2d:%.2d', [h, n]);
279 if ATime <> '@00:00' then Result := Result + ATime;
280end;
281
282{ TfrmORDtTm -------------------------------------------------------------------------------- }
283
284procedure TORfrmDtTm.FormCreate(Sender: TObject);
285begin
286 ResizeAnchoredFormToFont(self);
287 lstHour.TopIndex := 6;
288 FFromSelf := False;
289 calSelectChange(Self);
290end;
291
292procedure TORfrmDtTm.calSelectChange(Sender: TObject);
293begin
294 lblDate.Caption := FormatDateTime('mmmm d, yyyy', calSelect.CalendarDate);
295 FNowPressed := False;
296end;
297
298procedure TORfrmDtTm.imgPrevMonthMouseDown(Sender: TObject;
299 Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
300begin
301 pnlPrevMonth.BevelOuter := bvLowered;
302end;
303
304procedure TORfrmDtTm.imgNextMonthMouseDown(Sender: TObject;
305 Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
306begin
307 pnlNextMonth.BevelOuter := bvLowered;
308end;
309
310procedure TORfrmDtTm.imgPrevMonthClick(Sender: TObject);
311begin
312 calSelect.PrevMonth;
313end;
314
315procedure TORfrmDtTm.imgNextMonthClick(Sender: TObject);
316begin
317 calSelect.NextMonth;
318end;
319
320procedure TORfrmDtTm.imgPrevMonthMouseUp(Sender: TObject;
321 Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
322begin
323 pnlPrevMonth.BevelOuter := bvRaised;
324end;
325
326procedure TORfrmDtTm.imgNextMonthMouseUp(Sender: TObject;
327 Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
328begin
329 pnlNextMonth.BevelOuter := bvRaised;
330end;
331
332procedure TORfrmDtTm.cmdTodayClick(Sender: TObject);
333begin
334 calSelect.CalendarDate := ServerToday;
335 lstHour.ItemIndex := -1;
336 lstMinute.ItemIndex := -1;
337 txtTime.Text := '';
338end;
339
340procedure TORfrmDtTm.txtTimeChange(Sender: TObject);
341begin
342 if not FFromSelf then
343 begin
344 lstHour.ItemIndex := -1;
345 lstMinute.ItemIndex := -1;
346 end;
347 FNowPressed := False;
348end;
349
350procedure TORfrmDtTm.lstHourClick(Sender: TObject);
351begin
352 if lstMinute.ItemIndex < 0 then lstMinute.ItemIndex := 0;
353 lstMinuteClick(Self);
354end;
355
356procedure TORfrmDtTm.lstMinuteClick(Sender: TObject);
357var
358 AnHour, AMinute: Integer;
359// AmPm: string;
360begin
361 if lstHour.ItemIndex < 0 then Exit;
362
363 // if ampm time -
364 //case lstHour.ItemIndex of
365 // 0: AnHour := 12;
366 //1..12: AnHour := lstHour.ItemIndex;
367 //else AnHour := lstHour.ItemIndex - 12;
368 //end;
369 //if lstHour.ItemIndex > 11 then AmPm := 'PM' else AmPm := 'AM';
370
371 // if military time
372 AnHour := lstHour.ItemIndex;
373
374 AMinute := lstMinute.ItemIndex * 5;
375 FFromSelf := True;
376 // if ampm time -
377 //txtTime.Text := Format('%d:%.2d ' + AmPm, [AnHour, AMinute]);
378
379 // if military time
380 txtTime.Text := Format('%.2d:%.2d ', [AnHour, AMinute]);
381
382 FFromSelf := False;
383end;
384
385procedure TORfrmDtTm.cmdNowClick(Sender: TObject);
386begin
387 calSelect.CalendarDate := ServerToday;
388 //txtTime.Text := FormatDateTime('h:nn ampm', ServerNow); // if ampm time
389 txtTime.Text := FormatDateTime('hh:nn', ServerNow); // if ampm time
390 FNowPressed := True;
391end;
392
393procedure TORfrmDtTm.cmdMidnightClick(Sender: TObject);
394begin
395 //txtTime.Text := '11:59 PM'; // if ampm time
396 txtTime.Text := '23:59'; // if military time
397end;
398
399procedure TORfrmDtTm.cmdOKClick(Sender: TObject);
400var
401 x: string;
402begin
403 if TimeIsRequired and (Length(txtTime.Text) = 0) then
404 begin
405 InfoBox('An entry for time is required.', 'Missing Time', MB_OK);
406 Exit;
407 end;
408 if Length(txtTime.Text) > 0 then
409 begin
410 x := Trim(txtTime.Text);
411 if (x='00:00') or (x='0:00') or (x='00:00:00') or (x='0:00:00') then x := '00:00:01';
412 StrToTime(x);
413 txtTime.Text := x;
414 end;
415 ModalResult := mrOK;
416end;
417
418procedure TORfrmDtTm.cmdCancelClick(Sender: TObject);
419begin
420 ModalResult := mrCancel;
421end;
422
423{ TORDateTimeDlg }
424
425constructor TORDateTimeDlg.Create(AOwner: TComponent);
426begin
427 inherited Create(AOwner);
428 if not (csDesigning in ComponentState)
429 then FDateTime := ServerToday
430 else FDateTime := SysUtils.Date;
431end;
432
433function TORDateTimeDlg.Execute: Boolean;
434const
435 HORZ_SPACING = 8;
436var
437 frmDtTm: TORfrmDtTm;
438begin
439 frmDtTm := TORfrmDtTm.Create(Application);
440 try
441 with frmDtTm do
442 begin
443 calSelect.CalendarDate := Int(FDateTime);
444 if Frac(FDateTime) > 0
445 //then txtTime.Text := FormatDateTime('h:nn ampm', FDateTime); // if ampm time
446 then txtTime.Text := FormatDateTime('hh:nn', FDateTime); // if military time
447 if RequireTime then TimeIsRequired := True;
448 if DateOnly then
449 begin
450 txtTime.Visible := False;
451 lstHour.Visible := False;
452 lstMinute.Visible := False;
453 cmdNow.Visible := False;
454 cmdMidnight.Visible := False;
455 bvlFrame.Width := bvlFrame.Width - txtTime.Width - HORZ_SPACING;
456 cmdOK.Left := cmdOK.Left - txtTime.Width - HORZ_SPACING;
457 cmdCancel.Left := cmdOK.Left;
458 ClientWidth := ClientWidth - txtTime.Width - HORZ_SPACING;
459 end;
460 Result := (ShowModal = IDOK);
461 if Result then
462 begin
463 FDateTime := Int(calSelect.CalendarDate);
464 if Length(txtTime.Text) > 0 then FDateTime := FDateTime + StrToTime(txtTime.Text);
465 if FNowPressed
466 then FRelativeTime := 'NOW'
467 else FRelativeTime := RelativeDateTime(FDateTime);
468 end;
469 end;
470 finally
471 frmDtTm.Free;
472 end;
473end;
474
475function TORDateTimeDlg.GetFMDateTime: TFMDateTime;
476begin
477 Result := DateTimeToFMDateTime(FDateTime);
478end;
479
480procedure TORDateTimeDlg.SetDateOnly(Value: Boolean);
481begin
482 FDateOnly := Value;
483 if FDateOnly then
484 begin
485 FRequireTime := False;
486 FDateTime := Int(FDateTime);
487 end;
488end;
489
490procedure TORDateTimeDlg.SetFMDateTime(Value: TFMDateTime);
491begin
492 if Value > 0 then FDateTime := FMDateTimeToDateTime(Value);
493end;
494
495procedure TORDateTimeDlg.SetRequireTime(Value: Boolean);
496begin
497 FRequireTime := Value;
498 if FRequireTime then FDateOnly := False;
499end;
500
501{ TORDateEdit ----------------------------------------------------------------------------- }
502
503procedure TORDateEdit.CreateParams(var Params: TCreateParams);
504{ sets a one line edit box to multiline style so the editing rectangle can be changed }
505begin
506 inherited CreateParams(Params);
507 Params.Style := Params.Style or ES_MULTILINE or WS_CLIPCHILDREN;
508end;
509
510
511{ TORDateBox -------------------------------------------------------------------------------- }
512
513constructor TORDateBox.Create(AOwner: TComponent);
514begin
515 inherited Create(AOwner);
516 FButton := TBitBtn.Create(Self);
517 FButton.Parent := Self;
518 FButton.Width := 18;
519 FButton.Height := 17;
520 FButton.OnClick := ButtonClick;
521 FButton.TabStop := False;
522 FButton.Glyph.LoadFromResourceName(hInstance, 'BMP_ELLIPSIS');
523 FButton.Visible := True;
524 FFormat := FMT_DATETIME;
525end;
526
527procedure TORDateBox.WMSize(var Message: TWMSize);
528var
529 ofs: integer;
530
531begin
532 inherited;
533 if assigned(FButton) then
534 begin
535 if BorderStyle = bsNone then
536 ofs := 0
537 else
538 ofs := 4;
539 FButton.SetBounds(Width - FButton.Width - ofs, 0, FButton.Width, Height - ofs);
540 end;
541 SetEditRect;
542end;
543
544procedure TORDateBox.SetTemplateField(const Value: boolean);
545var
546 Y: integer;
547
548begin
549 if(FTemplateField <> Value) then
550 begin
551 FTemplateField := Value;
552 Y := TextHeightByFont(Font.Handle, FontHeightText);
553 if Value then
554 begin
555 FButton.Width := Y+2;
556 Height := Y;
557 BorderStyle := bsNone;
558 end
559 else
560 begin
561 FButton.Width := 18;
562 Height := y + AdjVertSize;
563 BorderStyle := bsSingle;
564 end;
565 end;
566end;
567
568procedure TORDateBox.ButtonClick(Sender: TObject);
569var
570 DateDialog: TORDateTimeDlg;
571 ParsedDate: TFMDateTime;
572begin
573 DateDialog := TORDateTimeDlg.Create(Application);
574 if Length(Text) > 0 then
575 begin
576 ParsedDate := ServerParseFMDate(Text);
577 if ParsedDate > -1 then FFMDateTime := ParsedDate else FFMDateTime := 0;
578 end;
579 DateDialog.DateOnly := FDateOnly;
580 DateDialog.FMDateTime := FFMDateTime;
581 DateDialog.RequireTime := FRequireTime;
582 if DateDialog.Execute then
583 begin
584 FFMDateTime := DateDialog.FMDateTime;
585 UpdateText;
586 FTimeIsNow := DateDialog.RelativeTime = 'NOW';
587 end;
588 DateDialog.Free;
589 if Visible and Enabled then //Some events may hide the component
590 SetFocus;
591end;
592
593procedure TORDateBox.Change;
594begin
595 inherited Change;
596 FTimeIsNow := False;
597end;
598
599procedure TORDateBox.KeyDown(var Key: Word; Shift: TShiftState);
600begin
601 inherited KeyDown(Key, Shift);
602 if (Key = VK_RETURN) then begin
603 FButton.Click;
604 Key := 0;
605 end;
606end;
607
608function TORDateBox.GetFMDateTime: TFMDateTime;
609begin
610 Result := 0;
611 if Length(Text) > 0 then Result := ServerParseFMDate(Text);
612 FFMDateTime := Result;
613end;
614
615function TORDateBox.GetRelativeTime: string;
616begin
617 Result := '';
618 if FTimeIsNow then Result := 'NOW'
619 else if UpperCase(Text) = 'NOW' then Result := 'NOW'
620 else if Length(Text) > 0 then
621 begin
622 FFMDateTime := ServerParseFMDate(Text);
623 if FFMDateTime > 0 then Result := RelativeDateTime(FMDateTimeToDateTime(FFMDateTime));
624 end;
625end;
626
627procedure TORDateBox.SetDateOnly(Value: Boolean);
628begin
629 FDateOnly := Value;
630 if FDateOnly then
631 begin
632 FRequireTime := False;
633 FFMDateTime := Int(FFMDateTime);
634 if FFormat = FMT_DATETIME then FFormat := FMT_DATEONLY;
635 end;
636 UpdateText;
637end;
638
639procedure TORDateBox.SetFMDateTime(Value: TFMDateTime);
640begin
641 FFMDateTime := Value;
642 UpdateText;
643end;
644
645procedure TORDateBox.SetRequireTime(Value: Boolean);
646begin
647 FRequireTime := Value;
648 if FRequireTime then
649 begin
650 if FFormat = FMT_DATEONLY then FFormat := FMT_DATETIME;
651 SetDateOnly(False);
652 end;
653end;
654
655procedure TORDateBox.SetEditRect;
656{ change the edit rectangle to not hide the calendar button - taken from SPIN.PAS sample }
657var
658 Loc: TRect;
659begin
660 SendMessage(Handle, EM_GETRECT, 0, LongInt(@Loc));
661 Loc.Bottom := ClientHeight + 1; // +1 is workaround for windows paint bug
662 Loc.Right := FButton.Left - 2;
663 Loc.Top := 0;
664 Loc.Left := 0;
665 SendMessage(Handle, EM_SETRECTNP, 0, LongInt(@Loc));
666end;
667
668procedure TORDateBox.UpdateText;
669begin
670 if FFMDateTime > 0 then
671 begin
672 if (FFormat =FMT_DATETIME) and (Frac(FFMDateTime) = 0)
673 then Text := FormatFMDateTime(FMT_DATEONLY, FFMDateTime)
674 else Text := FormatFMDateTime(FFormat, FFMDateTime);
675 end;
676end;
677
678procedure TORDateBox.Validate(var ErrMsg: string);
679begin
680 ErrMsg := '';
681 if Length(Text) > 0 then
682 begin
683 FFMDateTime := ServerParseFMDate(Text);
684 if FFMDateTime <= 0 then Errmsg := 'Invalid Date/Time';
685 if FRequireTime and (Frac(FFMDateTime) = 0) then ErrMsg := 'Time Required';
686 if FDateOnly and (Frac(FFMDateTime) > 0) then ErrMsg := 'Time not Required';
687 end;
688end;
689
690function TORDateBox.IsValid: Boolean;
691var
692 x: string;
693begin
694 Validate(x);
695 if Length(x) = 0 then Result := True else Result := False;
696 if Length(Text) = 0 then Result := False;
697end;
698
699procedure TORDateBox.SetCaption(const Value: string);
700begin
701 if not Assigned(FCaption) then begin
702 FCaption := TStaticText.Create(self);
703 FCaption.AutoSize := False;
704 FCaption.Height := 0;
705 FCaption.Width := 0;
706 FCaption.Visible := True;
707 FCaption.Parent := Parent;
708 FCaption.BringtoFront;
709 end;
710 FCaption.Caption := Value;
711end;
712
713function TORDateBox.GetCaption(): string;
714begin
715 result := FCaption.Caption;
716end;
717
718function IsLeapYear(AYear: Integer): Boolean;
719begin
720 Result := (AYear mod 4 = 0) and ((AYear mod 100 <> 0) or (AYear mod 400 = 0));
721end;
722
723function DaysPerMonth(AYear, AMonth: Integer): Integer;
724const
725 DaysInMonth: array[1..12] of Integer = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
726
727begin
728 if(AYear < 1) or (AMonth < 1) then
729 Result := 0
730 else
731 begin
732 Result := DaysInMonth[AMonth];
733 if (AMonth = 2) and IsLeapYear(AYear) then Inc(Result); { leap-year Feb is special }
734 end;
735end;
736
737{ TORDateCombo ------------------------------------------------------------------------- }
738
739const
740 ComboBoxAdjSize = 24;
741 EditAdjHorzSize = 8;
742 DateComboCtrlGap = 2;
743 FirstYear = 1800;
744 LastYear = 2200;
745
746type
747 TORDateComboEdit = class(TMaskEdit)
748 private
749 FTemplateField: boolean;
750 procedure SetTemplateField(const Value: boolean);
751 protected
752 property TemplateField: boolean read FTemplateField write SetTemplateField;
753 end;
754
755{ TORDateComboEdit }
756
757procedure TORDateComboEdit.SetTemplateField(const Value: boolean);
758begin
759 if(FTemplateField <> Value) then
760 begin
761 FTemplateField := Value;
762 if Value then
763 BorderStyle := bsNone
764 else
765 BorderStyle := bsSingle;
766 end;
767end;
768
769{ TORDateCombo }
770
771constructor TORDateCombo.Create(AOwner: TComponent);
772begin
773 inherited;
774 ControlStyle := ControlStyle - [csSetCaption, csAcceptsControls];
775 BevelOuter := bvNone;
776 FIncludeMonth := TRUE;
777 FIncludeDay := TRUE;
778 FIncludeBtn := TRUE;
779 OnResize := Resized;
780end;
781
782destructor TORDateCombo.Destroy;
783begin
784 KillObj(@FMonthCombo);
785 KillObj(@FDayCombo);
786 KillObj(@FYearEdit);
787 KillObj(@FYearUD);
788 KillObj(@FCalBtn);
789 inherited;
790end;
791
792function TORDateCombo.GetYearSize: integer;
793begin
794 Result := TextWidthByFont(Font.Handle, '8888') + EditAdjHorzSize;
795end;
796
797function TORDateCombo.InitDays(GetSize: boolean): integer;
798var
799 dy: integer;
800
801begin
802 Result := 0;
803 if(assigned(FDayCombo)) then
804 begin
805 dy := DaysPerMonth(FYear, FMonth) + 1;
806 while (FDayCombo.Items.Count < dy) do
807 begin
808 if(FDayCombo.Items.Count = 0) then
809 FDayCombo.Items.Add(' ')
810 else
811 FDayCombo.Items.Add(inttostr(FDayCombo.Items.Count));
812 end;
813 while (FDayCombo.Items.Count > dy) do
814 FDayCombo.Items.Delete(FDayCombo.Items.Count-1);
815 if(GetSize) then
816 Result := TextWidthByFont(Font.Handle, '88') + ComboBoxAdjSize;
817 if(FDay > (dy-1)) then
818 SetDay(dy-1);
819 end;
820end;
821
822function TORDateCombo.InitMonths(GetSize: boolean): integer;
823var
824 i, Size: integer;
825
826begin
827 Result := 0;
828 if(assigned(FMonthCombo)) then
829 begin
830 FMonthCombo.Items.Clear;
831 FMonthCombo.Items.Add(' ');
832 for i := 1 to 12 do
833 begin
834 if FLongMonths then
835 FMonthCombo.Items.Add(LongMonthNames[i])
836 else
837 FMonthCombo.Items.Add(ShortMonthNames[i]);
838 if(GetSize) then
839 begin
840 Size := TextWidthByFont(Font.Handle, FMonthCombo.Items[i]);
841 if(Result < Size) then
842 Result := Size;
843 end;
844 end;
845 if(GetSize) then
846 inc(Result, ComboBoxAdjSize);
847 end;
848end;
849
850procedure TORDateCombo.Rebuild;
851var
852 Wide, X, Y: integer;
853
854begin
855 if(not FRebuilding) then
856 begin
857 FRebuilding := TRUE;
858 try
859 ControlStyle := ControlStyle + [csAcceptsControls];
860 try
861 Y := TextHeightByFont(Font.Handle, FontHeightText);
862 if not FTemplateField then
863 inc(Y,AdjVertSize);
864 X := 0;
865 if(FIncludeMonth) then
866 begin
867 if(not assigned(FMonthCombo)) then
868 begin
869 FMonthCombo := TORComboBox.Create(Self);
870 FMonthCombo.Parent := Self;
871 FMonthCombo.Top := 0;
872 FMonthCombo.Left := 0;
873 FMonthCombo.Style := orcsDropDown;
874 FMonthCombo.DropDownCount := 13;
875 FMonthCombo.OnChange := MonthChanged;
876 end;
877 FMonthCombo.Font := Font;
878 FMonthCombo.TemplateField := FTemplateField;
879 Wide := InitMonths(TRUE);
880 FMonthCombo.Width := Wide;
881 FMonthCombo.Height := Y;
882 FMonthCombo.ItemIndex := FMonth;
883 inc(X, Wide + DateComboCtrlGap);
884
885 if(FIncludeDay) then
886 begin
887 if(not assigned(FDayCombo)) then
888 begin
889 FDayCombo := TORComboBox.Create(Self);
890 FDayCombo.Parent := Self;
891 FDayCombo.Top := 0;
892 FDayCombo.Style := orcsDropDown;
893 FDayCombo.OnChange := DayChanged;
894 FDayCombo.DropDownCount := 11;
895 end;
896 FDayCombo.Font := Font;
897 FDayCombo.TemplateField := FTemplateField;
898 Wide := InitDays(TRUE);
899 FDayCombo.Width := Wide;
900 FDayCombo.Height := Y;
901 FDayCombo.Left := X;
902 FDayCombo.ItemIndex := FDay;
903 inc(X, Wide + DateComboCtrlGap);
904 end
905 else
906 KillObj(@FDayCombo);
907 end
908 else
909 begin
910 KillObj(@FDayCombo);
911 KillObj(@FMonthCombo);
912 end;
913 if(not assigned(FYearEdit)) then
914 begin
915 FYearEdit := TORDateComboEdit.Create(Self);
916 FYearEdit.Parent := Self;
917 FYearEdit.Top := 0;
918 FYearEdit.EditMask := '9999;1; ';
919 FYearEdit.OnKeyPress := YearKeyPress;
920 FYearEdit.OnChange := YearChanged;
921 end;
922 FYearEdit.Font := Font;
923 TORDateComboEdit(FYearEdit).TemplateField := FTemplateField;
924 Wide := GetYearSize;
925 FYearEdit.Width := Wide;
926 FYearEdit.Height := Y;
927 FYearEdit.Left := X;
928 inc(X, Wide);
929 if(not assigned(FYearUD)) then
930 begin
931 FYearUD := TUpDown.Create(Self);
932 FYearUD.Parent := Self;
933 FYearUD.Thousands := FALSE;
934 FYearUD.Min := FirstYear-1;
935 FYearUD.Max := LastYear;
936 FYearUD.OnChangingEx := YearUDChange;
937 end;
938 FYearEdit.TabOrder := 0;
939 FYearUD.Top := 0;
940 FYearUD.Left := X;
941 FYearUD.Height := Y;
942 FYearUD.Position := FYear;
943 inc(X, FYearUD.Width + DateComboCtrlGap);
944 if(FIncludeBtn) then
945 begin
946 if(not assigned(FCalBtn)) then
947 begin
948 FCalBtn := TSpeedButton.Create(Self);
949 FCalBtn.Parent := Self;
950 FCalBtn.Top := 0;
951 FCalBtn.Glyph.LoadFromResourceName(hInstance, 'BMP_ELLIPSIS');
952 FCalBtn.OnClick := BtnClicked;
953 end;
954 Wide := FYearEdit.Height;
955 if(Wide > Y) then Wide := Y;
956 FCalBtn.Width := Wide;
957 FCalBtn.Height := Wide;
958 FCalBtn.Left := X;
959 inc(X, Wide + DateComboCtrlGap);
960 end
961 else
962 KillObj(@FCalBtn);
963 Self.Width := X - DateComboCtrlGap;
964 Self.Height := Y;
965 CheckDays;
966 FCtrlsCreated := TRUE;
967 DoChange;
968 finally
969 ControlStyle := ControlStyle - [csAcceptsControls];
970 end;
971 finally
972 FRebuilding := FALSE;
973 end;
974 end;
975end;
976
977procedure TORDateCombo.SetDay(Value: integer);
978begin
979 if(not assigned(FDayCombo)) and (not (csLoading in ComponentState)) then
980 Value := 0;
981 if(Value > DaysPerMonth(FYear, FMonth)) then
982 Value := 0;
983 if(FDay <> Value) then
984 begin
985 FDay := Value;
986 if(assigned(FDayCombo)) then
987 begin
988 if(FDayCombo.Items.Count <= FDay) then
989 InitDays(FALSE);
990 FDayCombo.ItemIndex := FDay;
991 end;
992 DoChange;
993 end;
994end;
995
996procedure TORDateCombo.SetIncludeBtn(const Value: boolean);
997begin
998 if(FIncludeBtn <> Value) then
999 begin
1000 FIncludeBtn := Value;
1001 Rebuild;
1002 end;
1003end;
1004
1005procedure TORDateCombo.SetIncludeDay(Value: boolean);
1006begin
1007 if(Value) and (not FIncludeMonth) then
1008 Value := FALSE;
1009 if(FIncludeDay <> Value) then
1010 begin
1011 FIncludeDay := Value;
1012 if(not Value) then FDay := 0;
1013 Rebuild;
1014 end;
1015end;
1016
1017procedure TORDateCombo.SetIncludeMonth(const Value: boolean);
1018begin
1019 if(FIncludeMonth <> Value) then
1020 begin
1021 FIncludeMonth := Value;
1022 if(not Value) then
1023 begin
1024 FIncludeDay := FALSE;
1025 FMonth := 0;
1026 FDay := 0;
1027 end;
1028 Rebuild;
1029 end;
1030end;
1031
1032procedure TORDateCombo.SetMonth(Value: integer);
1033begin
1034 if(not assigned(FMonthCombo)) and (not (csLoading in ComponentState)) then
1035 Value := 0;
1036 if(Value <0) or (Value > 12) then
1037 Value := 0;
1038 if(FMonth <> Value) then
1039 begin
1040 FMonth := Value;
1041 if(assigned(FMonthCombo)) then
1042 FMonthCombo.ItemIndex := FMonth;
1043 CheckDays;
1044 DoChange;
1045 end;
1046end;
1047
1048procedure TORDateCombo.SetLongMonths(const Value: boolean);
1049begin
1050 if(FLongMonths <> Value) then
1051 begin
1052 FLongMonths := Value;
1053 Rebuild;
1054 end;
1055end;
1056
1057procedure TORDateCombo.SetYear(const Value: integer);
1058begin
1059 if(FYear <> Value) then
1060 begin
1061 FYear := Value;
1062 if(FYear < FirstYear) or (FYear > LastYear) then
1063 FYear := 0;
1064 if(not FYearChanging) and (assigned(FYearEdit)) and (assigned(FYearUD)) then
1065 begin
1066 FYearChanging := TRUE;
1067 try
1068 if(FYear = 0) then
1069 begin
1070 FYearEdit.Text := ' ';
1071 FYearUD.Position := FirstYear-1
1072 end
1073 else
1074 begin
1075 FYearEdit.Text := IntToStr(FYear);
1076 FYearUD.Position := FYear;
1077 end;
1078 finally
1079 FYearChanging := FALSE;
1080 end;
1081 end;
1082 if(FMonth = 2) then
1083 InitDays(FALSE);
1084 CheckDays;
1085 DoChange;
1086 end;
1087end;
1088
1089procedure TORDateCombo.DayChanged(Sender: TObject);
1090begin
1091 FDay := FDayCombo.ItemIndex;
1092 if(FDay < 0) then
1093 FDay := 0;
1094 CheckDays;
1095 DoChange;
1096end;
1097
1098procedure TORDateCombo.MonthChanged(Sender: TObject);
1099begin
1100 FMonth := FMonthCombo.ItemIndex;
1101 if(FMonth < 0) then
1102 FMonth := 0;
1103 InitDays(FALSE);
1104 CheckDays;
1105 DoChange;
1106end;
1107
1108procedure TORDateCombo.YearChanged(Sender: TObject);
1109begin
1110 if FYearChanging then exit;
1111 FYearChanging := TRUE;
1112 try
1113 FYear := StrToIntDef(FYearEdit.Text, 0);
1114 if(FYear < FirstYear) or (FYear > LastYear) then
1115 FYear := 0;
1116 if(FYear = 0) then
1117 FYearUD.Position := FirstYear-1
1118 else
1119 FYearUD.Position := FYear;
1120 if(FMonth = 2) then
1121 InitDays(FALSE);
1122 CheckDays;
1123 DoChange;
1124 finally
1125 FYearChanging := FALSE;
1126 end;
1127end;
1128
1129procedure TORDateCombo.CheckDays;
1130var
1131 MaxDays: integer;
1132
1133begin
1134 if(FIncludeMonth and assigned(FMonthCombo)) then
1135 begin
1136 FMonthCombo.Enabled := (FYear > 0);
1137 if (FYear = 0) then
1138 SetMonth(0);
1139 if(FIncludeMonth and FIncludeDay and assigned(FDayCombo)) then
1140 begin
1141 FDayCombo.Enabled := ((FYear > 0) and (FMonth > 0));
1142 MaxDays := DaysPerMonth(FYear, FMonth);
1143 if(FDay > MaxDays) then
1144 SetDay(MaxDays);
1145 end;
1146 end;
1147end;
1148
1149procedure TORDateCombo.Loaded;
1150begin
1151 inherited;
1152 if(not FCtrlsCreated) then
1153 Rebuild;
1154end;
1155
1156procedure TORDateCombo.Paint;
1157begin
1158 if(not FCtrlsCreated) then
1159 Rebuild;
1160 inherited;
1161end;
1162
1163procedure TORDateCombo.BtnClicked(Sender: TObject);
1164var
1165 mm, dd, yy: integer;
1166 m, d, y: word;
1167 DateDialog: TORDateTimeDlg;
1168
1169begin
1170 DateDialog := TORDateTimeDlg.Create(self);
1171 try
1172 mm := FMonth;
1173 dd := FDay;
1174 yy := FYear;
1175 DecodeDate(Now, y, m, d);
1176 if(FYear = 0) then FYear := y;
1177 if(FYear = y) then
1178 begin
1179 if((FMonth = 0) or (FMonth = m)) and (FDay = 0) then
1180 begin
1181 FMonth := m;
1182 FDay := d;
1183 end;
1184 end;
1185 if(FMonth = 0) then
1186 FMonth := 1;
1187 if(FDay = 0) then
1188 FDay := 1;
1189 DateDialog.FMDateTime := GetFMDate;
1190 DateDialog.DateOnly := TRUE;
1191 DateDialog.RequireTime := FALSE;
1192 if DateDialog.Execute then
1193 begin
1194 FYear := 0;
1195 FMonth := 0;
1196 FDay := 0;
1197 SetFMDate(DateDialog.FMDateTime);
1198 end
1199 else
1200 begin
1201 SetYear(yy);
1202 SetMonth(mm);
1203 SetDay(dd);
1204 end;
1205 finally
1206 DateDialog.Free;
1207 end;
1208end;
1209
1210procedure TORDateCombo.YearUDChange(Sender: TObject; var AllowChange: Boolean;
1211 NewValue: Smallint; Direction: TUpDownDirection);
1212var
1213 y, m, d: word;
1214
1215begin
1216 if FYearChanging then exit;
1217 FYearChanging := TRUE;
1218 try
1219 if FYearUD.Position = (FirstYear-1) then
1220 begin
1221 DecodeDate(Now, y, m, d);
1222 FYear := y;
1223 FYearUD.Position := y;
1224 AllowChange := FALSE;
1225 end
1226 else
1227 FYear := NewValue;
1228 if(FYear < FirstYear) or (FYear > LastYear) then
1229 FYear := 0;
1230 if(FYear = 0) then
1231 FYearEdit.Text := ' '
1232 else
1233 FYearEdit.Text := IntToStr(FYear);
1234 if(FMonth = 2) then
1235 InitDays(FALSE);
1236 CheckDays;
1237 DoChange;
1238 finally
1239 FYearChanging := FALSE;
1240 end;
1241end;
1242
1243procedure TORDateCombo.YearKeyPress(Sender: TObject; var Key: Char);
1244begin
1245 if(Key in ['0'..'9']) and (FYearEdit.Text = ' ') then
1246 begin
1247 FYearEdit.Text := Key + ' ';
1248 Key := #0;
1249 FYearEdit.SelStart := 1;
1250 FYearEdit.SelText := '';
1251 end;
1252end;
1253
1254function TORDateCombo.GetFMDate: TFMDateTime;
1255begin
1256 if(FYear < FirstYear) then
1257 Result := 0
1258 else
1259 Result := ((FYear - 1700) * 10000 + FMonth * 100 + FDay);
1260end;
1261
1262procedure TORDateCombo.SetFMDate(const Value: TFMDateTime);
1263var
1264 ival, mo, dy: integer;
1265
1266begin
1267 if(Value = 0) then
1268 begin
1269 SetYear(0);
1270 SetMonth(0);
1271 end
1272 else
1273 begin
1274 ival := trunc(Value);
1275 if(length(inttostr(ival)) <> 7) then
1276 exit;
1277 dy := (ival mod 100);
1278 ival := ival div 100;
1279 mo := ival mod 100;
1280 ival := ival div 100;
1281 SetYear(ival + 1700);
1282 SetMonth(mo);
1283 InitDays(FALSE);
1284 SetDay(dy);
1285 end;
1286end;
1287
1288function TORDateCombo.DateText: string;
1289begin
1290 Result := '';
1291 if(FYear > 0) then
1292 begin
1293 if(FMonth > 0) then
1294 begin
1295 if FLongMonths then
1296 Result := LongMonthNames[FMonth]
1297 else
1298 Result := ShortMonthNames[FMonth];
1299 if(FDay > 0) then
1300 Result := Result + ' ' + IntToStr(FDay);
1301 Result := Result + ', ';
1302 end;
1303 Result := Result + IntToStr(FYear);
1304 end;
1305end;
1306
1307procedure TORDateCombo.DoChange;
1308begin
1309 if assigned(FOnChange) then
1310 FOnChange(Self);
1311end;
1312
1313procedure TORDateCombo.Resized(Sender: TObject);
1314begin
1315 Rebuild;
1316end;
1317
1318procedure TORDateCombo.CMFontChanged(var Message: TMessage);
1319begin
1320 inherited;
1321 Rebuild;
1322end;
1323
1324function TORDateCombo.Text: string;
1325var
1326 tmp, fmt, m: string;
1327
1328begin
1329 Result := '';
1330 tmp := FloatToStr(FMDate);
1331 if(tmp <> '') and (tmp <> '0') and (length(Tmp) >= 7) then
1332 begin
1333 if FLongMonths then
1334 m := 'mmmm'
1335 else
1336 m := 'mmm';
1337 if(copy(tmp,4,4) = '0000') then
1338 fmt := 'yyyy'
1339 else
1340 if(copy(tmp,6,2) = '00') then
1341 fmt := m + ', YYYY'
1342 else
1343 fmt := m + ' D, YYYY';
1344 Result := FormatFMDateTimeStr(fmt, tmp)
1345 end;
1346end;
1347
1348
1349procedure Register;
1350{ used by Delphi to put components on the Palette }
1351begin
1352 RegisterComponents('CPRS', [TORDateTimeDlg, TORDateBox, TORDateCombo]);
1353end;
1354
1355procedure TORDateCombo.SetTemplateField(const Value: boolean);
1356begin
1357 if FTemplateField <> Value then
1358 begin
1359 FTemplateField := Value;
1360 Rebuild;
1361 end;
1362end;
1363
1364initialization
1365 uServerToday := 0;
1366
1367end.
Note: See TracBrowser for help on using the repository browser.