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 SHAPESPR

Project Structure


SHAPESPR.DPR

program ShapesPr;

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

{$R *.RES}

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

SHAPESF.PAS

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;
    Print1: 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);
    procedure Print1Click(Sender: TObject);
  private
    { Private declarations }
    ShapesList: TList;
    CurrShape: TBaseShape;
    fDragging: Boolean;
    procedure CommonPaint(Canvas: TCanvas; Scale: Integer = 1);
  public
    { Public declarations }
  end;

var
  ShapesForm: TShapesForm;

implementation

{$R *.DFM}

uses
  Printers;

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);
begin
   CommonPaint (Canvas);
end;

procedure TShapesForm.CommonPaint (
  Canvas: TCanvas; Scale: Integer);
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, Scale);
  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;

procedure TShapesForm.Print1Click(Sender: TObject);
var
   Scale, Scale1: Integer;
begin
  Scale := Printer.PageWidth div ClientWidth;
  Scale1 := Printer.PageHeight div ClientHeight;
  if Scale1 < Scale then
     Scale := Scale1;
  Printer.BeginDoc;
  try
    CommonPaint (Printer.Canvas, Scale);
    Printer.EndDoc;
  except
    Printer.Abort;
    raise;
  end;
end;

end.

SHAPESH.PAS

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; Scale: Integer = 1); 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; Scale: Integer = 1); override;
  end;

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


implementation

{ TBaseShape }

procedure TBaseShape.Paint (Canvas: TCanvas; Scale: Integer);
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; Scale: Integer);
begin
  inherited Paint (Canvas);
  Canvas.Ellipse (fRect.Left * Scale, fRect.Top * Scale,
    fRect.Right * Scale, fRect.Bottom * Scale)
end;

{ TRectShape }

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

end.

SHAPESF.DFM

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 Print1: TMenuItem
        Caption = '&Print'
        OnClick = Print1Click
      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