Marco's Web Center

Menu for Development

Site Menu
Object Pascal Handbook
Delphi Handbooks Collection
Mastering Borland Delphi 2005
(Old) White Papers
(Old)Tools
(Old) Conferences

My Other Sites
Italian Site (www.marcocantu.it)
the delphi search

Spirit of delphi

Advertising
Home My Blog Books Object Pascal Marco

Home: Code Repository: Mastering Delphi 5

Project DATELIST

Project Structure


DATELIST.DPR

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.

DATEFORM.PAS

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.

DATES.PAS

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.

DATEL.PAS

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.

DATEFORM.DFM

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