Project Structure

• DateList.dpr
• DateForm.pas
• Dates.pas
• DateL.pas
• DateForm.dfm

program Datelist;

uses
  Forms,
  DateForm in 'DateForm.pas' {Form1},
  Dates in 'Dates.pas',
  DateL in 'DateL.pas';

{$R *.RES}

begin
  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.

unit DateForm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, DateL;

type
  TForm1 = class(TForm)
    ButtonAddDates: TButton;
    ButtonAddButton: TButton;
    ListBox1: TListBox;
    ComboBox1: TComboBox;
    procedure ButtonAddDatesClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure ButtonAddButtonClick(Sender: TObject);
    procedure ComboBox1Change(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    ListI: TDateListI;
    ListW: TDateListW;
  public
    procedure 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 do
  begin
    Date := TDate.Create (1900 + Random (200),
      1 + Random (12), 1 + Random (28));
    ListI.Add (Date);
  end;
  for I := 1 to 10 do
  begin
    Date := TDate.Create (1900 + Random (200),
      1 + Random (12), 1 + Random (28));
    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(TButton.Create (nil)));
  TList(ListI).Add (TButton.Create (nil));
  UpdateList;
end;

procedure TForm1.UpdateList;
var
  I: Integer;
begin
  ListBox1.Clear;
  try
    if ComboBox1.ItemIndex = 0 then
      for I := 0 to ListI.Count - 1 do
        Listbox1.Items.Add (
          ListI [I].GetText)
    else
      for I := 0 to ListW.Count - 1 do
        Listbox1.Items.Add (
          ListW [I].GetText);
  except
    on E: Exception do
      Listbox1.Items.Add ('Error: ' +
        E.Message);
  end;
end;

procedure TForm1.ComboBox1Change(Sender: TObject);
begin
  UpdateList;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  // delete lists
  ListW.Free;
  ListI.Free;
end;

end.

unit Dates;

interface

uses
  Classes, SysUtils;

type
  TDate = class (TComponent)
  private
    fDate: TDateTime;
    FOnChange: TNotifyEvent;
    function GetYear: Integer;
    function GetDay: Integer;
    function GetMonth: Integer;
    procedure SetDay(const Value: Integer);
    procedure SetMonth(const Value: Integer);
    procedure SetYear(const Value: Integer);
  protected
    procedure DoChange; virtual;
  public
    constructor Create (AOwner: TComponent); overload; override;
    constructor Create (y, m, d: Integer); reintroduce; overload;
    procedure SetValue (y, m, d: Integer); overload;
    procedure SetValue (NewDate: TDateTime); overload;
    function LeapYear: Boolean;
    procedure Increase (NumberOfDays: Integer = 1);
    procedure Decrease (NumberOfDays: Integer = 1);
    function GetText: string; virtual;
    property Text: string read GetText;
  published
    property Day: Integer read GetDay write SetDay;
    property Month: Integer read GetMonth write SetMonth;
    property Year: Integer read GetYear write SetYear;
    property OnChange: TNotifyEvent
      read FonChange write FOnChange;
  end;

  // custom exception
  EDateOutOfRange = class (Exception)
  end;

procedure Register;

implementation

procedure TDate.SetValue (y, m, d: Integer);
begin
  fDate := EncodeDate (y, m, d);
  // fire the event
  DoChange;
end;

function TDate.LeapYear: Boolean;
begin
  // compute leap years, considering "exceptions"
  if (GetYear mod 4 <> 0) then
    LeapYear := False
  else if (GetYear mod 100 <> 0) then
    LeapYear := True
  else if (GetYear mod 400 <> 0) then
    LeapYear := False
  else
    LeapYear := True;
end;

procedure TDate.Increase (NumberOfDays: Integer = 1);
begin
  fDate := fDate + NumberOfDays;
  // fire the event
  DoChange;
end;

function TDate.GetText: string;
begin
  GetText := DateToStr (fDate);
end;

procedure TDate.Decrease (NumberOfDays: Integer = 1);
begin
  fDate := fDate - NumberOfDays;
  // fire the event
  DoChange;
end;

constructor TDate.Create (y, m, d: Integer);
begin
  fDate := EncodeDate (y, m, d);
end;

constructor TDate.Create (AOwner: TComponent);
begin
  inherited Create (AOwner);
  // today...
  fDate := Date;
end;

function TDate.GetYear: Integer;
var
  y, m, d: Word;
begin
  DecodeDate (fDate, y, m, d);
  Result := y;
end;

procedure TDate.SetValue(NewDate: TDateTime);
begin
  fDate := NewDate;
  // fire the event
  DoChange;
end;

function TDate.GetDay: Integer;
var
  y, m, d: Word;
begin
  DecodeDate (fDate, y, m, d);
  Result := d;
end;

function TDate.GetMonth: Integer;
var
  y, m, d: Word;
begin
  DecodeDate (fDate, y, m, d);
  Result := m;
end;

procedure TDate.SetDay(const Value: Integer);
begin
  if (Value < 0) or (Value > 31) then
    raise EDateOutOfRange.Create ('Invalid month');
  SetValue (Year, Month, Value);
end;

procedure TDate.SetMonth(const Value: Integer);
begin
  if (Value < 0) or (Value > 12) then
    raise EDateOutOfRange.Create ('Invalid month');
  SetValue (Year, Value, Day);
end;

procedure TDate.SetYear(const Value: Integer);
begin
  SetValue (Value, Month, Day);
end;

procedure TDate.DoChange;
begin
  if Assigned (FOnChange) then
    FOnChange (Self);
end;

procedure Register;
begin
  RegisterComponents ('Md5', [TDate]);
end;

end.

unit DateL;

interface

uses
  Classes, Dates, Contnrs;

type
  // inheritance based
  TDateListI = class (TObjectList)
  protected
    procedure SetObject (Index: Integer; Item: TDate);
    function GetObject (Index: Integer): TDate;
  public
    function Add (Obj: TDate): Integer;
    procedure Insert (Index: Integer; Obj: TDate);
    property Objects [Index: Integer]: TDate
      read GetObject write SetObject; default;
  end;
  // wrapper based
  TDateListW = class(TObject)
  private
    FList: TObjectList;
    procedure SetObject (Index: Integer; Obj: TDate);
    function GetObject (Index: Integer): TDate;
    function GetCount: Integer;
  public
    constructor Create;
    destructor Destroy; override;
    function Add (Obj: TDate): Integer;
    function Remove (Obj: TDate): Integer;
    function IndexOf (Obj: TDate): Integer;
    property Count: Integer read GetCount;
    property Objects [Index: Integer]: TDate
      read GetObject write SetObject; default;
  end;

implementation

// inherited version

function TDateListI.Add (Obj: TDate): Integer;
begin
  Result := inherited Add (Obj)
end;

procedure TDateListI.SetObject (Index: Integer; Item: TDate);
begin
  inherited SetItem (Index, Item)
end;

function TDateListI.GetObject (Index: Integer): TDate;
begin
  Result := inherited GetItem (Index) as TDate;
end;

procedure TDateListI.Insert(Index: Integer; Obj: TDate);
begin
  inherited Insert(Index, Obj);
end;

// embedded version

constructor TDateListW.Create;
begin
  inherited Create;
  FList := TObjectList.Create;
end;

destructor TDateListW.Destroy;
begin
  FList.Free;
  inherited Destroy;
end;

function TDateListW.GetObject (Index: Integer): TDate;
begin
  Result := FList [Index] as TDate;
end;

procedure TDateListW.SetObject (Index: Integer; Obj: TDate);
begin
  FList[Index] := Obj;
end;

function TDateListW.GetCount: Integer;
begin
  Result := FList.Count;
end;

function TDateListW.Add (Obj: TDate): Integer;
begin
  Result := FList.Add (Obj);
end;

// another method you can optionally add
{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 do
    if List[I] <> FList[I] then
      Exit;
  Result := True;
end;}

function TDateListW.IndexOf(Obj: TDate): Integer;
begin
  Result := fList.IndexOf (Obj);
end;

// another method you can optionally add
{procedure TDateListW.Insert(Index: Integer; Obj: TDate);
begin
  fList.Insert (Index, Obj);
end;}

function TDateListW.Remove(Obj: TDate): Integer;
begin
  Result := fList.Remove (Obj);
end;

end.

object Form1: TForm1
  Left = 197
  Top = 113
  Width = 353
  Height = 291
  Caption = 'Safe List'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = True
  OnCreate = FormCreate
  OnDestroy = FormDestroy
  PixelsPerInch = 96
  TextHeight = 13
  object ButtonAddDates: TButton
    Left = 16
    Top = 16
    Width = 100
    Height = 25
    Caption = 'Add 10 &Dates'
    TabOrder = 0
    OnClick = ButtonAddDatesClick
  end
  object ButtonAddButton: TButton
    Left = 16
    Top = 56
    Width = 100
    Height = 25
    Caption = 'Add &Button'
    TabOrder = 1
    OnClick = ButtonAddButtonClick
  end
  object ListBox1: TListBox
    Left = 128
    Top = 48
    Width = 193
    Height = 193
    ItemHeight = 13
    TabOrder = 2
  end
  object ComboBox1: TComboBox
    Left = 128
    Top = 16
    Width = 193
    Height = 21
    Style = csDropDownList
    ItemHeight = 13
    Items.Strings = (
      'Inherited List'
      'Wrapper List')
    TabOrder = 3
    OnChange = ComboBox1Change
  end
end