Home: Code Repository: Mastering Delphi 5

Project SHAPES

Project Structure

SHAPES.DPR
SHAPESF.PAS
SHAPESH.PAS
SHAPESF.DFM

program Shapes;

uses
  Forms,
  ShapesF in 'ShapesF.pas' {ShapesForm},
  ShapesH in 'ShapesH.pas';

{$R *.RES}

begin
  Application.CreateForm(TShapesForm, ShapesForm);
  Application.Run;
end.

unit ShapesF;

interface

uses
  Windows, Classes, Graphics, Forms, Controls, Menus,
  Dialogs, SysUtils, ShapesH;

type
  TShapesForm = class(TForm)
    MainMenu1: TMainMenu;
    ColorDialog1: TColorDialog;
    File1: TMenuItem;
    New1: TMenuItem;
    N1: TMenuItem;
    Exit1: TMenuItem;
    Colors1: TMenuItem;
    PenColor1: TMenuItem;
    BrushColor1: TMenuItem;
    BackGroundColor1: TMenuItem;
    Size1: TMenuItem;
    IncreasePenSize1: TMenuItem;
    DecreasePenSize1: TMenuItem;
    Help1: TMenuItem;
    AboutShapes1: TMenuItem;
    procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure PenColor1Click(Sender: TObject);
    procedure BrushColor1Click(Sender: TObject);
    procedure BackGroundColor1Click(Sender: TObject);
    procedure IncreasePenSize1Click(Sender: TObject);
    procedure DecreasePenSize1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure AboutShapes1Click(Sender: TObject);
    procedure Exit1Click(Sender: TObject);
    procedure New1Click(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure FormDestroy(Sender: TObject);
    procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    { Private declarations }
    ShapesList: TList;
    CurrShape: TBaseShape;
    fDragging: Boolean;
  public
    { Public declarations }
  end;

var
  ShapesForm: TShapesForm;

implementation

{$R *.DFM}

function NormalizeRect (ARect: TRect): TRect;
var
  tmp: Integer;
begin
  if ARect.Bottom < ARect.Top then
  begin
    tmp := ARect.Bottom;
    ARect.Bottom := ARect.Top;
    ARect.Top := tmp;
  end;
  if ARect.Right < ARect.Left then
  begin
    tmp := ARect.Right;
    ARect.Right := ARect.Left;
    ARect.Left := tmp;
  end;
  Result := ARect;
end;

procedure TShapesForm.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Button = mbLeft then
  begin
    // activate dragging
    fDragging := True;
    SetCapture (Handle);

    // create the proper object
    if ssShift in Shift then
      CurrShape := TEllShape.Create
    else
      CurrShape := TRectShape.Create;

    // set the style and colors
    CurrShape.PenSize := Canvas.Pen.Width;
    CurrShape.PenColor := Canvas.Pen.Color;
    CurrShape.BrushColor := Canvas.Brush.Color;

    // set the initial position
    CurrShape.Left := X;
    CurrShape.Top := Y;
    CurrShape.Right := X;
    CurrShape.Bottom := Y;
    Canvas.DrawFocusRect (CurrShape.Rect);

    // add to the list
    ShapesList.Add (CurrShape);
  end;
end;

procedure TShapesForm.PenColor1Click(Sender: TObject);
begin
  // select a new color for the pen
  ColorDialog1.Color := Canvas.Pen.Color;
  if ColorDialog1.Execute then
    Canvas.Pen.Color := ColorDialog1.Color;
end;

procedure TShapesForm.BrushColor1Click(Sender: TObject);
begin
  // select a new color for the brush
  ColorDialog1.Color := Canvas.Brush.Color;
  if ColorDialog1.Execute then
    Canvas.Brush.Color := ColorDialog1.Color;
end;

procedure TShapesForm.BackGroundColor1Click(Sender: TObject);
begin
  // select a new color for the background of the form
  ColorDialog1.Color := Color;
  if ColorDialog1.Execute then
    Color := ColorDialog1.Color;
end;

procedure TShapesForm.IncreasePenSize1Click(Sender: TObject);
begin
  // increase the size of the pen
  Canvas.Pen.Width := Canvas.Pen.Width + 2;
  DecreasePenSize1.Enabled := True;
end;

procedure TShapesForm.DecreasePenSize1Click(Sender: TObject);
begin
  {decrease the size of the pen,
  avoiding to let it go below zero}
  Canvas.Pen.Width := Canvas.Pen.Width - 2;
  if Canvas.Pen.Width < 3 then
    DecreasePenSize1.Enabled := False;
end;

procedure TShapesForm.FormCreate(Sender: TObject);
begin
  // initialization and creation of the list
  ShapesList := TList.Create;
  Canvas.Pen.Style := psInsideFrame;
end;

procedure TShapesForm.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
var
  ARect: TRect;
begin
  // copy the mouse coordinates to the title
  Caption := Format ('Shapes (x=%d, y=%d)', [X, Y]);

  // dragging code
  if fDragging then
  begin
    // remove and redraw the dragging rectangle
    ARect := NormalizeRect (CurrShape.Rect);
    Canvas.DrawFocusRect (ARect);
    CurrShape.Right := X;
    CurrShape.Bottom := Y;
    ARect := NormalizeRect (CurrShape.Rect);
    Canvas.DrawFocusRect (ARect);
  end;
end;

procedure TShapesForm.AboutShapes1Click(Sender: TObject);
begin
  // show a message box
  MessageDlg ('Shapes application'#13 +
    'from "Mastering Delphi" by Marco Cant�',
    mtInformation, [mbOK], 0);
end;

procedure TShapesForm.Exit1Click(Sender: TObject);
begin
  // close the form and the application
  Close;
end;

procedure TShapesForm.New1Click(Sender: TObject);
var
  I: Integer;
begin
  {repaint the surface, after removing the elements
  from the list, if there is any element and the
  user confirms the request}
  if (ShapesList.Count > 0) and
    (MessageDlg ('Are you sure you want to delete all the shapes?',
    mtConfirmation, [mbYes, mbNo], 0) = idYes) then
  begin
    // delete each object
    for I := ShapesList.Count - 1 downto 0 do
      TBaseShape (ShapesList [I]).Free;
    ShapesList.Clear;
    Refresh;
  end;
end;

procedure TShapesForm.FormPaint(Sender: TObject);
var
  I, OldPenW: Integer;
  AShape: TBaseShape;
  OldPenCol, OldBrushCol: TColor;
begin
  // store the current Canvas attributes
  OldPenCol := Canvas.Pen.Color;
  OldPenW := Canvas.Pen.Width;
  OldBrushCol := Canvas.Brush.Color;

  // repaint each shape of the list
  for I := 0 to ShapesList.Count - 1 do
  begin
    AShape := ShapesList.Items [I];
    AShape.Paint (Canvas);
  end;

  // reset the current Canvas attributes
  Canvas.Pen.Color := OldPenCol;
  Canvas.Pen.Width := OldPenW;
  Canvas.Brush.Color := OldBrushCol;
end;

procedure TShapesForm.FormCloseQuery(Sender: TObject;
  var CanClose: Boolean);
begin
  {ask the user to confirm closing}
  if MessageDlg ('Are you sure you want to exit?',
      mtConfirmation, [mbYes, mbNo], 0) = idNo then
    CanClose := False;
end;

procedure TShapesForm.FormDestroy(Sender: TObject);
var
  I: Integer;
begin
  // delete each object
  for I := ShapesList.Count - 1 downto 0 do
    TBaseShape (ShapesList [I]).Free;
  ShapesList.Free;
end;

procedure TShapesForm.FormMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  ARect: TRect;
begin
  if fDragging then
  begin
    // end dragging
    ReleaseCapture;
    fDragging := False;

    // set the final size
    ARect := NormalizeRect (CurrShape.Rect);
    Canvas.DrawFocusRect (ARect);
    CurrShape.Right := X;
    CurrShape.Bottom := Y;

    // optimized invalidate code
    ARect := NormalizeRect (CurrShape.Rect);
    InvalidateRect (Handle, @ARect, False);
  end;
end;

end.

unit ShapesH;

interface

uses
  Windows, Graphics;

type
  TBaseShape = class
  private
    FBrushColor: TColor;
    FPenColor: TColor;
    FPenSize: Integer;
    procedure SetBrushColor(const Value: TColor);
    procedure SetPenColor(const Value: TColor);
    procedure SetPenSize(const Value: Integer);
    procedure SetBottom(const Value: Integer);
    procedure SetLeft(const Value: Integer);
    procedure SetRight(const Value: Integer);
    procedure SetTop(const Value: Integer);
  protected
    FRect: TRect;
  public
    procedure Paint (Canvas: TCanvas); virtual;
  published
    property PenSize: Integer read FPenSize write SetPenSize;
    property PenColor: TColor read FPenColor write SetPenColor;
    property BrushColor: TColor read FBrushColor write SetBrushColor;
    property Left: Integer write SetLeft;
    property Right: Integer write SetRight;
    property Top: Integer write SetTop;
    property Bottom: Integer write SetBottom;
    property Rect: TRect read FRect;
  end;

type
  TEllShape = class (TBaseShape)
    procedure Paint (Canvas: TCanvas); override;
  end;

  TRectShape = class (TBaseShape)
    procedure Paint (Canvas: TCanvas); override;
  end;


implementation

{ TBaseShape }

procedure TBaseShape.Paint (Canvas: TCanvas);
begin
  // set the attributes
  Canvas.Pen.Color := fPenColor;
  Canvas.Pen.Width := fPenSize;
  Canvas.Brush.Color := fBrushColor;
end;

procedure TBaseShape.SetBottom(const Value: Integer);
begin
  fRect.Bottom := Value;
end;

procedure TBaseShape.SetBrushColor(const Value: TColor);
begin
  FBrushColor := Value;
end;

procedure TBaseShape.SetLeft(const Value: Integer);
begin
  fRect.Left := Value;
end;

procedure TBaseShape.SetPenColor(const Value: TColor);
begin
  FPenColor := Value;
end;

procedure TBaseShape.SetPenSize(const Value: Integer);
begin
  FPenSize := Value;
end;

procedure TBaseShape.SetRight(const Value: Integer);
begin
  fRect.Right := Value;
end;

procedure TBaseShape.SetTop(const Value: Integer);
begin
  fRect.Top := Value;
end;

{ TEllShape }

procedure TEllShape.Paint(Canvas: TCanvas);
begin
  inherited Paint (Canvas);
  Canvas.Ellipse (fRect.Left, fRect.Top,
    fRect.Right, fRect.Bottom)
end;

{ TRectShape }

procedure TRectShape.Paint(Canvas: TCanvas);
begin
  inherited Paint (Canvas);
  Canvas.Rectangle (fRect.Left, fRect.Top,
    fRect.Right, fRect.Bottom)
end;

end.

object ShapesForm: TShapesForm
  Left = 253
  Top = 143
  Width = 435
  Height = 300
  Caption = 'Shapes'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -13
  Font.Name = 'System'
  Font.Style = []
  Menu = MainMenu1
  OldCreateOrder = True
  Position = poDefault
  OnCloseQuery = FormCloseQuery
  OnCreate = FormCreate
  OnDestroy = FormDestroy
  OnMouseDown = FormMouseDown
  OnMouseMove = FormMouseMove
  OnMouseUp = FormMouseUp
  OnPaint = FormPaint
  PixelsPerInch = 96
  TextHeight = 16
  object MainMenu1: TMainMenu
    Left = 24
    Top = 8
    object File1: TMenuItem
      Caption = '&File'
      object New1: TMenuItem
        Caption = '&New'
        OnClick = New1Click
      end
      object N1: TMenuItem
        Caption = '-'
      end
      object Exit1: TMenuItem
        Caption = '&Exit'
        OnClick = Exit1Click
      end
    end
    object Colors1: TMenuItem
      Caption = '&Colors'
      object PenColor1: TMenuItem
        Caption = '&Pen Color...'
        OnClick = PenColor1Click
      end
      object BrushColor1: TMenuItem
        Caption = '&Brush Color...'
        OnClick = BrushColor1Click
      end
      object BackGroundColor1: TMenuItem
        Caption = 'Back&Ground Color...'
        OnClick = BackGroundColor1Click
      end
    end
    object Size1: TMenuItem
      Caption = '&Size'
      object IncreasePenSize1: TMenuItem
        Caption = '&Increase Pen Size'
        OnClick = IncreasePenSize1Click
      end
      object DecreasePenSize1: TMenuItem
        Caption = '&Decrease Pen Size'
        Enabled = False
        OnClick = DecreasePenSize1Click
      end
    end
    object Help1: TMenuItem
      Caption = '&Help'
      object AboutShapes1: TMenuItem
        Caption = '&About Shapes...'
        OnClick = AboutShapes1Click
      end
    end
  end
  object ColorDialog1: TColorDialog
    Ctl3D = True
    Left = 96
    Top = 8
  end
end