Delphi World - Список объектов класса TDate
Delphi World - это проект, являющийся сборником статей и малодокументированных возможностей  по программированию в среде Delphi. Здесь вы найдёте работы по следующим категориям: delphi, delfi, borland, bds, дельфи, делфи, дэльфи, дэлфи, programming, example, программирование, исходные коды, code, исходники, source, sources, сорцы, сорсы, soft, programs, программы, and, how, delphiworld, базы данных, графика, игры, интернет, сети, компоненты, классы, мультимедиа, ос, железо, программа, интерфейс, рабочий стол, синтаксис, технологии, файловая система...
Список объектов класса TDate



unit Dates;

interface

uses
  SysUtils, Classes;

type
  TDate = class (TComponent)
  private
    FMonth, FDay, FYear: Integer;
    FOnChange: TNotifyEvent;
  protected
    function DaysInMonth: Integer;
    procedure SetMonth (Value: Integer);
    procedure SetYear (Value: Integer);
    procedure SetDay (Value: Integer);
    procedure DoChange; virtual;
  public
    constructor 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: string read GetText;
  published
    property 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 exception
type
  EDateOutOfRange = class (Exception);

procedure Register;

implementation

constructor TDate.Create (AOwner: TComponent);
var
  Y, D, M: Word;
begin
  inherited 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;
begin
  if 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 value
  try
    FYear := y;
    // check the ranges
    SetMonth (m);
    SetDay (d);
    DoChange;
  except
    on EDateOutOfRange do
    begin
      // reset the values
      FYear := OldY;
      FMonth := OldM;
      // let the error show up
      raise;
    end;
  end;
end;

procedure TDate.SetMonth (Value: Integer);
begin
  if (Value >= 1) and (Value <= 12) then
  begin
    FMonth := Value;
    DoChange;
  end
  else
    raise EDateOutOfRange.Create ('Month out of range');
end;

procedure TDate.SetYear (Value: Integer);
begin
  FYear := Value;
  DoChange;
end;

procedure TDate.SetDay (Value: Integer);
begin
  if (Value >= 1) and (Value <= DaysInMonth) then
  begin
    FDay := Value;
    DoChange;
  end
  else
    raise 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
  else if (FYear mod 100 <> 0) then
    LeapYear := True
  else if (FYear mod 400 <> 0) then
    LeapYear := False
  else
    LeapYear := True;
end;

function TDate.DaysInMonth: Integer;
begin
  case 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 month
  if FDay < DaysInMonth then
    Inc (FDay) // increase the value by 1
  else
  // if it is not in December
    if FMonth < 12 then
    begin
      // Day 1 of next month
      Inc (FMonth);
      FDay := 1;
    end
    else
    begin
      // else it is next year New Year's Day
      Inc (FYear);
      FMonth := 1;
      FDay := 1;
    end;
  DoChange;
end;

// exactly the reverse of the Increase method
procedure TDate.Decrease;
begin
  if FDay > 1 then
    Dec (FDay) // decrease the value by 1
  else
    // it is the first of a month
    if FMonth > 1 then
    begin
      // assign last day of previous month
      Dec (FMonth);
      FDay := DaysInMOnth;
    end
    else
    // it is the first of January
    begin
      // 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 times
  for N := 1 to NumberOfDays do
    Increase;
end;

procedure TDate.Subtract (NumberOfDays: Integer);
var
  N: Integer;
begin
  // decrease the day n times
  for N := 1 to NumberOfDays do
    Decrease;
end;

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

end.


unit DateL;

interface

uses
  Classes, Dates;

type
  // inheritance based
  TDateListI = class (TList)
  protected
    procedure Put(Index: Integer; Item: TDate);
    function Get (Index: Integer): TDate;
  public
    procedure 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;
  public
    constructor 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 version

procedure TDateListI.Add (Obj: TDate);
begin
  inherited Add (Obj)
end;

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

function TDateListI.Get (Index: Integer): TDate;
begin
  Result := inherited Get (Index);
end;

// embedded version

constructor TDateListW.Create;
begin
  inherited 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 do
    if List[I] <> FList[I] then
      Exit;
  Result := True;
end;

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;
    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;
  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.Init (
      1 + Random (12),
      1 + Random (28), // required to be safe
      1900 + Random (200));
    ListI.Add (Date);
  end;
  for I := 1 to 10 do
  begin
    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;
  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);
var
  I: Integer;
begin
  // remove objects from lists
  for I := 0 to ListW.Count - 1 do
    ListW [I].Free;
  for I := 0 to ListI.Count - 1 do
    ListI [I].Free;
end;

end.

Загрузить весь проект

Проект Delphi World © Выпуск 2002 - 2017
Автор проекта: Эксклюзивные курсы программирования