Delphi - Graphic editor / take 1

disclaimer

the source code of this page may not appear correctly in certain browsers
due to special characters. Have a look at the source of this HTML page
with notepad instead
Graphic editor

The featured graphic editor is a demo to show some capabilities. It is not intended to be a tool. It has no memory, and no further editing capabilities beside :
draw a line
draw a rectangle
draw free hand
clear the lot
It is based on a TImage.
Plus, it shows the useage of rubber banding.
the code

unit Graphicstest1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, Menus, StdCtrls, ComCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    Image1: TImage;
    StatusBar1: TStatusBar;
    GroupBox1: TGroupBox;
    LineLabel: TLabel;
    ColorLabel: TLabel;
    RectLabel: TLabel;
    PopupMenu1: TPopupMenu;
    ClearAll: TMenuItem;
    ColorDialog1: TColorDialog;
    freehandlabel: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure LineLabelClick(Sender: TObject);
    procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure Image1MouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure ClearAllClick(Sender: TObject);
    procedure ColorLabelClick(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure RectLabelClick(Sender: TObject);
    procedure freehandlabelClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
   lastx,lasty:integer;
   startx,starty:integer;
   state:integer;
   DrawColor:TColor;
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
 state:=0;
 image1.canvas.pen.Color:=clwhite;
 image1.Canvas.Brush.Color:=clwhite;
 image1.Canvas.Rectangle(0,0,image1.width-1,image1.height-1);
 image1.canvas.pen.Color:=clblack;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
 //
end;

procedure TForm1.FormResize(Sender: TObject);
begin
 groupbox1.width:=clientwidth;
 image1.width:=clientwidth;
 image1.Height:=clientheight-60;
 image1.picture.bitmap.width:=image1.width;
 image1.picture.bitmap.height:=image1.Height;
end;

procedure TForm1.LineLabelClick(Sender: TObject); // caption:='Line'
begin
 state:=1;
 rectlabel.Color:=clbtnface;
 linelabel.Color:=clwhite;
 freehandlabel.color:=clbtnface;
end;

procedure TForm1.RectLabelClick(Sender: TObject); // caption:='Rectangle'
begin
 state:=3;
 linelabel.Color:=clbtnface;
 rectlabel.Color:=clwhite;
 freehandlabel.color:=clbtnface;
end;

procedure TForm1.freehandlabelClick(Sender: TObject); // caption:='Freehand'
begin
 state:=5;
 linelabel.Color:=clbtnface;
 rectlabel.Color:=clbtnface;
 freehandlabel.color:=clwhite;
end;

procedure TForm1.ColorLabelClick(Sender: TObject);  // caption:='Color'
begin
 if colordialog1.Execute then begin
  drawcolor:=colordialog1.Color;
  colorlabel.Color:=DrawColor;
  end;
end;


// starts selected drawing action
//
procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
 if state=1 then begin  // linemode - start line
  startx:=x; starty:=y;
  lastx:=x;lasty:=y;
  state:=2;
  image1.Canvas.Pen.Color:=clwhite;
 end;
 if state=3 then begin // rect mode - start rectangle
  startx:=x; starty:=y;
  lastx:=x;lasty:=y;
  state:=4;
  image1.Canvas.Pen.Color:=clwhite;
  image1.Canvas.Brush.Color:=clwhite;
 end;
 if state=5 then begin // freehand mode - start
  image1.Canvas.Pen.Color:=drawcolor;
  state:=6;
  end;
end;

procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
  var p:TGraphicBase;
begin
 if state=2 then begin   // linemode - draw
  image1.Canvas.Pen.Mode:=pmXOR;
  image1.Canvas.MoveTo(startx,starty);
  image1.Canvas.LineTo(lastx,lasty);
  image1.Canvas.Pen.Mode:=pmXOR;
  image1.Canvas.MoveTo(startx,starty);
  image1.Canvas.LineTo(x,y);
  lastx:=x; lasty:=y;
  end;
 if state=4 then begin   // rectmode - draw
  image1.Canvas.Pen.Mode:=pmXOR;
  image1.Canvas.MoveTo(startx,starty);
  image1.Canvas.LineTo(startx,lasty);
  image1.Canvas.LineTo(lastx,lasty);
  image1.Canvas.LineTo(lastx,starty);
  image1.Canvas.LineTo(startx,starty);
  image1.Canvas.Pen.Mode:=pmXOR;
  image1.Canvas.MoveTo(startx,starty);
  image1.Canvas.LineTo(startx,y);
  image1.Canvas.LineTo(x,y);
  image1.Canvas.LineTo(x,starty);
  image1.Canvas.LineTo(startx,starty);
  lastx:=x; lasty:=y;
  end;
 if state=6 then begin // freehand mode - draw
  image1.canvas.Pixels[x,y]:=drawcolor;
 end;
 statusbar1.Panels[0].Text:='mouse '+inttostr(x)+' '+inttostr(y);
end;

// ends current drawing action
//
procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var Line:TGraphicLine;
begin
 if state=2 then begin  // linemode - end line
  image1.Canvas.Pen.Mode:=pmXOR;
  image1.Canvas.MoveTo(startx,starty);
  image1.Canvas.LineTo(lastx,lasty);
  image1.Canvas.Pen.Color:=drawcolor;
  image1.Canvas.Pen.Mode:=pmCopy;
  image1.Canvas.MoveTo(startx,starty);
  image1.Canvas.LineTo(lastx,lasty);
  state:=1;
  end;
 if state=4 then begin  // rectmode - end line
  image1.Canvas.Pen.Mode:=pmXOR;
  image1.Canvas.MoveTo(startx,starty);
  image1.Canvas.LineTo(startx,lasty);
  image1.Canvas.LineTo(lastx,lasty);
  image1.Canvas.LineTo(lastx,starty);
  image1.Canvas.LineTo(startx,starty);
  image1.Canvas.Pen.Color:=drawcolor;
  image1.Canvas.Brush.Color:=drawcolor;
  image1.Canvas.Pen.Mode:=pmCopy;
  image1.Canvas.MoveTo(startx,starty);
  image1.Canvas.LineTo(startx,lasty);
  image1.Canvas.LineTo(lastx,lasty);
  image1.Canvas.LineTo(lastx,starty);
  image1.Canvas.LineTo(startx,starty);
  state:=3;
  end;
 if state=6 then begin // freehand mode - end
  state:=5;
  end;
end;


// Since the image cannot receive keys, set form.keypreview:=true
//
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
 if key=$1B then begin // ESC
  if state=1 then linelabel.Color:=clbtnface;
  if state=3 then rectlabel.Color:=clbtnface;
  if state=5 then freehandlabel.Color:=clbtnface;
  state:=0;
  end;
end;

procedure TForm1.ClearAllClick(Sender: TObject); // popup menu choice
begin
 image1.canvas.pen.Color:=clwhite;
 image1.Canvas.Brush.Color:=clwhite;
 image1.Canvas.Rectangle(0,0,image1.width-1,image1.height-1);
end;

end.
Feedback is welcome
sponsored links

Delphi
home

last updated: 21.june.03

Copyright (99,2003) Ing.Büro R.Tschaggelar