Delphi Programming Unleashed/Delphi_Programming_Unleashed_SAMS_Publishing_1995.iso/chap28/object4/classdef.pas

Pascal/Delphi Source File | 1995-03-21 | 5.3 KB | 258 lines

unit Classdef;

{ Program copyright (c) 1995 by Charles Calvert }
{ Project Name: OBJECT4 }

interface

uses
  Classes, Controls, Graphics,
  Dialogs, ExtCtrls, Buttons;

const
  idBlue = 100;
  idYellow = 101;
  idGreen = 102;
  idViolet = 103;

type
  THMethod = (hmScreen, hmDisk);

  TMyObject = class(TImage)
  public
    procedure ShowHierarchy; virtual;
  end;

  THierarchy = class(TMyObject)
  private
    FHierarchyMethod: THMethod;
    procedure SetHierarchy(H: THMethod);
  public
    procedure ShowHierarchy; override;
  published
    property HierarchyMethod: THMethod read FHierarchyMethod write SetHierarchy;
  end;

  TWidget = class(THierarchy)
  private
    FQuantity: LongInt;
    FBoxSize: LongInt;
    FMaxQuantity: LongInt;
    FDescription: string;
    FTwin: TSpeedButton;
  protected
    procedure MouseDown(Sender: TObject; Button: TMouseButton;
                           Shift: TShiftState; X, Y: Integer);
  public
    constructor Create(AOwner: TComponent); override;
    procedure Sell(Amount: LongInt); virtual;
    procedure Stock; virtual;
    function GetName: string; virtual;
  published
    property Description: string read FDescription;
    property Quantity: LongInt read FQuantity write FQuantity;
    property Twin: TSpeedButton read FTwin write FTwin;
    property BoxSize: LongInt read FBoxSize write FBoxSize;
    property OnMouseDown;
  end;

  TBlue = class(TWidget)
    public
    constructor Create(AOwner: TComponent); override;
    procedure ShowHierarchy; override;
  end;

  TYellow = class(TWidget)
    public
    constructor Create(AOwner: TComponent); override;
    procedure ShowHierarchy; override;
  end;

  TGreen = class(TWidget)
    public
    constructor Create(AOwner: TComponent); override;
    procedure ShowHierarchy; override;
  end;

  TViolet = class(TWidget)
    public
    constructor Create(AOwner: TComponent); override;
    procedure ShowHierarchy; override;
  end;

implementation

uses
  HierDlg,
  Reports,
  StrBox;

var
  FActive: Boolean;

{ --- TMyObject --- }

procedure TMyObject.ShowHierarchy;
const
  CR = #13#10;
var
  AClass: TClass;
  S: string;
begin
  S := ClassName;
  AClass := ClassParent;
  while AClass <> nil do begin
    S := S + CR + AClass.ClassName;
    AClass := AClass.ClassParent;
  end;
  MessageDlg(S, mtInformation, [mbOk], 0);
end;

{ --- THierarchy --- }

procedure THierarchy.ShowHierarchy;
var
  F: System.Text;
  AClass: TClass;
begin
  if FHierarchyMethod = hmscreen then
    inherited ShowHierarchy
  else begin
    System.Assign(F, 'inherit.txt');
    ReWrite(F);
    WriteLn(F, ClassName);
    AClass := ClassParent;
    while AClass <> nil do begin
      WriteLn(F, AClass.ClassName);
      AClass := AClass.ClassParent;
    end;
    Close(F);
  end;
end;


procedure THierarchy.SetHierarchy(H: THMethod);
begin
  FHierarchyMethod := H;
end;

{ --- TWidget --- }

constructor TWidget.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FBoxSize := 5;
  OnMouseDown := MouseDown;
  FDescription := 'I don''t talk!';
  ClientWidth := 25;
  ClientHeight := 25;
  FActive := True;
end;

function TWidget.GetName: string;
begin
  result := StripFromFront(ClassName, 1);
end;

procedure TWidget.Stock;
begin
  FQuantity := FQuantity + FBoxSize;
end;

procedure TWidget.Sell(Amount: LongInt);
begin
  if FActive then
    FQuantity := FQuantity - FBoxSize;
end;

procedure TWidget.MouseDown(Sender: TObject; Button: TMouseButton;
                            Shift: TShiftState; X, Y: Integer);
begin
  FActive := False;
  Report.Run(Self);
  FActive := True;
end;

{ --- TBlue --- }

constructor TBlue.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Picture.LoadFromFile('blue.bmp');
  FDescription := 'A blue widget!';
  FQuantity := 800;
  FBoxSize := 50;
  FMaxQuantity := 1000;
end;

procedure TBlue.ShowHierarchy;
begin
  if FHierarchyMethod = hmDisk then
    inherited ShowHierarchy
  else
    HierarchyDlg.Run(Self, clBlue);
end;

{ --- TYellow --- }

constructor TYellow.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Picture.LoadFromFile('yellow.bmp');
  FDescription := 'A yellow widget!';
  FQuantity := 10;
  FBoxSize := 1;
  FMaxQuantity := 15;
end;

procedure TYellow.ShowHierarchy;
begin
  if FHierarchyMethod = hmDisk then
    inherited ShowHierarchy
  else
    HierarchyDlg.Run(Self, clYellow);
end;

{ --- TGreen --- }

constructor TGreen.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Picture.LoadFromFile('green.bmp');
  FDescription := 'A green widget!';
  FQuantity := 500;
  FBoxSize := 50;
  FMaxQuantity := 650;
end;

procedure TGreen.ShowHierarchy;
begin
  if FHierarchyMethod = hmDisk then
    inherited ShowHierarchy
  else
    HierarchyDlg.Run(Self, clGreen);
end;


{ --- TViolet --- }

constructor TViolet.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Picture.LoadFromFile('violet.bmp');
  FDescription := 'Violet widget palette';
  FQuantity := 600;
  FBoxSize := 70;
  FMaxQuantity := 740;
end;

procedure TViolet.ShowHierarchy;
begin
  if FHierarchyMethod = hmDisk then
    inherited ShowHierarchy
  else
    HierarchyDlg.Run(Self, clPurple);
end;

end.