unit Dates;
interfaceuses
SysUtils, Classes;
type
TDate = class (TComponent)
private
FMonth, FDay, FYear: Integer;
FOnChange: TNotifyEvent;
protectedfunction DaysInMonth: Integer;
procedure SetMonth (Value: Integer);
procedure SetYear (Value: Integer);
procedure SetDay (Value: Integer);
procedure DoChange; virtual;
publicconstructor Create (AOwner: TComponent); override;
constructor Init (m, d, y: Integer);
procedure SetValue (m, d, y: Integer);
function LeapYear: Boolean;
procedure Increase;
procedure Decrease;
procedure Add (NumberOfDays: Integer);
procedure Subtract (NumberOfDays: Integer);
function GetText: string;
// properties:property Text: stringread GetText;
publishedproperty Day: Integer read FDay write SetDay;
property Month: Integer read FMonth write SetMonth;
property Year: Integer read FYear write SetYear;
// event:property OnChange: TNotifyEvent
read FonChange write FOnChange;
end;
// dates exceptiontype
EDateOutOfRange = class (Exception);
procedureRegister;
implementationconstructor TDate.Create (AOwner: TComponent);
var
Y, D, M: Word;
begininherited Create (AOwner);
// today...
DecodeDate (Now, Y, M, D);
FYear := Y;
FMonth := M;
FDay := D;
end;
constructor TDate.Init (m, d, y: Integer);
begin
SetValue (m, d, y);
end;
procedure TDate.DoChange;
beginif Assigned (FOnChange) then
FOnChange (self);
end;
procedure TDate.SetValue (m, d, y: Integer);
var
OldY, OldM: Integer;
begin// store the old value
OldY := FYear;
OldM := FMonth;
// assing the new valuetry
FYear := y;
// check the ranges
SetMonth (m);
SetDay (d);
DoChange;
excepton EDateOutOfRange dobegin// reset the values
FYear := OldY;
FMonth := OldM;
// let the error show upraise;
end;
end;
end;
procedure TDate.SetMonth (Value: Integer);
beginif (Value >= 1) and (Value <= 12) thenbegin
FMonth := Value;
DoChange;
endelseraise EDateOutOfRange.Create ('Month out of range');
end;
procedure TDate.SetYear (Value: Integer);
begin
FYear := Value;
DoChange;
end;
procedure TDate.SetDay (Value: Integer);
beginif (Value >= 1) and (Value <= DaysInMonth) thenbegin
FDay := Value;
DoChange;
endelseraise EDateOutOfRange.Create ('Day out of range');
end;
function TDate.LeapYear: Boolean;
begin// compute leap years, considering "exceptions"if (FYear mod 4 <> 0) then
LeapYear := False
elseif (FYear mod 100 <> 0) then
LeapYear := True
elseif (FYear mod 400 <> 0) then
LeapYear := False
else
LeapYear := True;
end;
function TDate.DaysInMonth: Integer;
begincase FMonth of
1, 3, 5, 7, 8, 10, 12:
DaysInMonth := 31;
4, 6, 9, 11:
DaysInMonth := 30;
2:
if (LeapYear) then
DaysInMonth := 29
else
DaysInMonth := 28;
else// if the month is not correct
DaysInMonth := 0;
end;
end;
procedure TDate.Increase;
begin// if this day is not the last of the monthif FDay < DaysInMonth then
Inc (FDay) // increase the value by 1else// if it is not in Decemberif FMonth < 12 thenbegin// Day 1 of next month
Inc (FMonth);
FDay := 1;
endelsebegin// else it is next year New Year's Day
Inc (FYear);
FMonth := 1;
FDay := 1;
end;
DoChange;
end;
// exactly the reverse of the Increase methodprocedure TDate.Decrease;
beginif FDay > 1 then
Dec (FDay) // decrease the value by 1else// it is the first of a monthif FMonth > 1 thenbegin// assign last day of previous month
Dec (FMonth);
FDay := DaysInMOnth;
endelse// it is the first of Januarybegin// assign last day of previous year
Dec (FYear);
FMonth := 12;
FDay := DaysInMOnth;
end;
DoChange;
end;
function TDate.GetText: string;
begin
GetText := Format ('%s %d, %d',
[LongMonthNames[Month], Day, Year]);
end;
procedure TDate.Add (NumberOfDays: Integer);
var
N: Integer;
begin// increase the day n timesfor N := 1 to NumberOfDays do
Increase;
end;
procedure TDate.Subtract (NumberOfDays: Integer);
var
N: Integer;
begin// decrease the day n timesfor N := 1 to NumberOfDays do
Decrease;
end;
procedureRegister;
begin
RegisterComponents ('Md3', [TDate]);
end;
end.
unit DateL;
interfaceuses
Classes, Dates;
type// inheritance based
TDateListI = class (TList)
protectedprocedure Put(Index: Integer; Item: TDate);
function Get (Index: Integer): TDate;
publicprocedure Add (Obj: TDate);
property Items[Index: Integer]: TDate
read Get write Put; default;
end;
// wrapper based
TDateListW = class(TObject)
private
FList: TList;
function Get(Index: Integer): TDate;
procedure Put(Index: Integer; Item: TDate);
function GetCount: Integer;
publicconstructor Create;
destructor Destroy; override;
function Add(Item: TDate): Integer;
function Equals(List: TDateListW): Boolean;
property Count: Integer read GetCount;
property Items[Index: Integer]: TDate
read Get write Put; default;
end;
implementation// inherited versionprocedure TDateListI.Add (Obj: TDate);
begininherited Add (Obj)
end;
procedure TDateListI.Put(Index: Integer; Item: TDate);
begininherited Put (Index, Item)
end;
function TDateListI.Get (Index: Integer): TDate;
begin
Result := inherited Get (Index);
end;
// embedded versionconstructor TDateListW.Create;
begininherited Create;
FList := TList.Create;
end;
destructor TDateListW.Destroy;
begin
FList.Free;
inherited Destroy;
end;
function TDateListW.Get(Index: Integer): TDate;
begin
Result := FList[Index];
end;
procedure TDateListW.Put(Index: Integer; Item: TDate);
begin
FList[Index] := Item;
end;
function TDateListW.GetCount: Integer;
begin
Result := FList.Count;
end;
function TDateListW.Add(Item: TDate): Integer;
begin
Result := FList.Add(Item);
end;
function TDateListW.Equals(List: TDateListW): Boolean;
var
I: Integer;
begin
Result := False;
if List.Count <> FList.Count then Exit;
for I := 0 to List.Count - 1 doif List[I] <> FList[I] then
Exit;
Result := True;
end;
end.
unit DateForm;
interfaceuses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, DateL;
type
TForm1 = class(TForm)
ButtonAddDates: TButton;
ButtonAddButton: TButton;
ListBox1: TListBox;
ComboBox1: TComboBox;
ButtonAddPointer: TButton;
procedure ButtonAddDatesClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure ButtonAddButtonClick(Sender: TObject);
procedure ButtonAddPointerClick(Sender: TObject);
procedure ComboBox1Change(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
ListI: TDateListI;
ListW: TDateListW;
publicprocedure UpdateList;
end;
var
Form1: TForm1;
implementation{$R *.DFM}uses
Dates;
procedure TForm1.ButtonAddDatesClick(Sender: TObject);
var
I: Integer;
Date: TDate;
begin
Randomize;
for I := 1 to 10 dobegin
Date := TDate.Init (
1 + Random (12),
1 + Random (28), // required to be safe
1900 + Random (200));
ListI.Add (Date);
end;
for I := 1 to 10 dobegin
Date := TDate.Init (
1 + Random (12),
1 + Random (28), // required to be safe
1900 + Random (200));
ListW.Add (Date);
end;
UpdateList;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
ListI := TDateListI.Create;
ListW := TDateListW.Create;
ComboBox1.ItemIndex := 0;
end;
procedure TForm1.ButtonAddButtonClick(Sender: TObject);
begin
ListW.Add (TDate(Sender));
TList(ListI).Add (Sender);
UpdateList;
end;
procedure TForm1.ButtonAddPointerClick(Sender: TObject);
var
P: Pointer;
begin
P := @Form1;
ListW.Add (P);
ListI.Add (P);
UpdateList;
end;
procedure TForm1.UpdateList;
var
I: Integer;
begin
ListBox1.Clear;
tryif ComboBox1.ItemIndex = 0 thenfor I := 0 to ListI.Count - 1 do
Listbox1.Items.Add (
ListI [I].GetText)
elsefor I := 0 to ListW.Count - 1 do
Listbox1.Items.Add (
ListW [I].GetText);
excepton E:Exception do
Listbox1.Items.Add ('Error: ' +
E.MEssage);
end;
end;
procedure TForm1.ComboBox1Change(Sender: TObject);
begin
UpdateList;
end;
procedure TForm1.FormDestroy(Sender: TObject);
var
I: Integer;
begin// remove objects from listsfor I := 0 to ListW.Count - 1 do
ListW [I].Free;
for I := 0 to ListI.Count - 1 do
ListI [I].Free;
end;
end.
Статья Список объектов класса TDate раздела Компоненты и Классы Классы может быть полезна для разработчиков на Delphi и FreePascal.
Комментарии и вопросы
Материалы статей собраны из открытых источников, владелец сайта не претендует на авторство. Там где авторство установить не удалось, материал подаётся без имени автора. В случае если Вы считаете, что Ваши права нарушены, пожалуйста, свяжитесь с владельцем сайта.